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1 . 0  INTRODUCTION 


This  manual  describes  the  Ambulatory  Care  Data  Base 
(ACDB)  Study  data  collection  systems,  system  development 
techniques  and  mainframe  procedures  and  programs  used  in 
maintaining  and  reporting  ambulatory  care  data. 

The  many  program  listings  and  explanations  are 
directed  more  for  a  programmer  or  systems  analyst  than  a 
reader  with  little  computer  background.  However,  there 
are  tables  of  the  data  structure  and  historical 
narrative  that  will  aid  in  the  data  analysis.  This 
manual  does  not  contain  operational  descriptions  of  the 
systems  since  other  manuals  have  addressed  that  topic. 

Historical  information  is  sometimes  furnished  to 
illustrate  the  reasons  why  sor  e  things  were  done  and  to 
point  out  problem  areas.  In  some  cases,  warnings  are 
given  to  avoid  certain  steps  or  processes  should  the 
method  be  used  in  a  future  study  or  standard  system. 
Alternatively,  the  manual  contains  instructions  for  the 
use  of  various  development  tools  and  programs, 
descriptions  of  the  programs  used,  and  data  structure 
from  beginning  to  end. 

The  development  process  continued  throughout  the 
project.  A  major  revision  of  all  data  collection  forms 
required  reprogramming  all  scanner  and  BASIC  programs 
during  the  spring  of  1987.  In  some  cases,  programs 
never  reached  completion  as  the  data  collection  process 
ended  rather  abruptly  in  the  summer  of  1987.  Thus,  this 
manual  is  similar  to  a  snapshot  of  where  the  project  had 
been  and  was  as  of  September  1987. 

The  development  effort  can  be  divided  into  four 
major  areas.  The  first  area  pertained  to  the  optical 
scanner  which  was  used  to  read  the  raw  data.  The  second 
area  concerned  the  IBM  XT  system  used  to  drive  the 
scanner.  This  XT  performed  data  conversions  and  edits 
while  preparing  data  for  the  data  base.  The  third  major 
area  involved  the  IBM  XT  which  stored  the  data  in  a 
fourth  generation  data  base  management  system  (DBMS) 
called  FOCUS.  FOCUS  was  used  to  load  data,  write 
reports,  prepare  files  for  shipment,  and  perform  other 
data  maintenance  activities.  The  fourth  area  related  to 
the  mainframe  computer  at  Ft.  Detrick.  Here  data  from 
all  the  sites  was  collected  and  placed  into  cumulative 
files.  The  DBMS  on  the  mainframe  was  also  FOCUS,  making 
many  load  and  report  programs  similar  to  the  PC 
versions.  Operating  procedures  such  as  uploading  data, 
processing  Standard  Installation  Division  Personnel 
System  (SIDPERS)  data,  processing  Defense  Eligibility 
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Enrollment  System  (DEERS)  data,  loading  data  into  FOCUS 
and  downloading  patient  data  to  be  sent  back  to  the 
sites  are  described  within  this  document. 

An  entire  document  could  be  written  about  end  user 
support  but  little  is  discussed  here.  Ft.  Detrick 
provided  technical  support  to  all  sites  throughout  the 
project.  The  hospital  site  temporary  employees  had 
little  or  no  computer  experience.  They  quickly  learned 
to  follow  detailed  directions  and  also  provided  feedback 
when  problems  occurred.  Their  support  allowed  for  rapid 
resolution  of  problems,  thus  preventing  major 
disruptions.  As  a  result,  these  temporary  employees 
were  instrumental  to  the  success  of  the  study. 

Lastly,  the  project  used  various  languages  and 
equipment  with  specialized  documentation.  This  manual 
does  not  duplicate  any  documentation  already  written  but 
provides  references  to  the  documentation.  In  some 
cases,  additional  explanations  are  furnished  where 
external  documentation  was  lacking  or  insufficient. 
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2.1  OPTICAL  SCANNER  OVERVIEW 

The  ACDB  study  team  designed  optical  scanning  forms 
for  each  outpatient  specialty  or  clinic.  The  forms  were 
filled  out  (bubbled  in)  by  clerks  and/or  providers  in 
each  clinic.  Completed  forms  were  taken  to  a  central 
location  where  they  were  read  by  a  National  Computer 
Systems  (NCS)  scanner  (Models  7001-7006) .  Some  editing 
of  the  forms  was  performed  through  a  dedicated  computer 
within  the  scanner.  The  scanners  at  each  site  were 
connected  to  an  IBM  XT  personal  computer  which 
controlled  the  scanner  as  well  as  performed  additional 
editing  functions.  Forms  were  accepted  or  rejected  by 
the  scanner.  Accepted  forms  were  directed  to  a  hopper 
on  the  scanner,  and  the  data  was  decoded  and  saved  in  a 
file  on  the  hard  disk  drive  of  the  IBM  computer. 

Rejected  forms  were  directed  to  a  reject  hopper  where 
they  could  be  corrected  and  rescanned.  Correction 
sometimes  involved  sending  the  forms  back  to  the 
originating  clinic  for  further  information. 

2 . 2  DEVELOPMENT  SCANNER 

The  scanner  used  for  development  was  an  NCS  model 

7001. 

2.3  SCANNER  CONSIDERATIONS 

The  scanner  read  both  sides  of  the  forms 
simultaneously  by  using  an  optical  read  head  that  shone 
through  the  paper.  This  method  required  the  forms  to  be 
designed  so  that  no  two  marks  were  positioned 
back-to-back.  Stray  marks  carelessly  written  on  one 
side  of  the  form  could  be  read  as  an  input  value  on  the 
opposite  side.  Also,  special  paper  had  to  be  used. 

2 . 4  SCANNER  PROGRAMMING 

2,4.1  OVERVIEW 

The  scanner  computer  was  programmed  by  bubbling  in 
resolution  sheets.  Each  resolution  sheet  (see  sample  of 
blank  sheet)  had  nine  boxes  where  coordinates  and  other 
information  about  the  type  of  input  could  be  entered. 

Ten  to  twenty  resolution  sheets  were  required  for  each 
form.  The  resolution  sheets  were  compiled  by  using  the 
scanner  compilation  utility.  The  compiled  program  was 
stored  on  a  diskette  which  resided  in  the  scanner  during 
scanning  of  forms. 


2.4.2  PROGRAMMING  RESOLUTION  SHEETS 


Details  for  programming  the  resolution  sheets  are 
provided  in  the  User's  Guide  for  the  Sentry  70  Scanners 
and  thus  will  not  be  covered  here.  The  process  of 
coding  the  resolution  sheets  was  tedious  and  subject  to 
errors.  One  bubble  error  in  a  20  sheet  program  could 
cause  considerable  debugging  time. 

There  were  numerous  data  fields  on  the  ACDB  forms 
that  were  identical  from  form  to  form.  The  forms  were 
designed  so  that  the  identical  fields  were  located  in 
the  same  coordinates  on  every  form  where  possible.  In 
this  way  many  resolution  sheet  boxes  could  be  duplicated 
from  program  to  program.  Manual  copying  of  the 
resolution  sheets  by  clerks  introduced  an  average  of  one 
or  more  errors  per  page,  and  the  debugging  time  negated 
any  time  saved  by  this  method. 

NCS  supplied  a  program  for  the  IBM  PC  that  allowed 
entering  the  resolution  sheet  data  at  a  computer 
terminal.  The  program  printed  out  (preslugged) 
continuous  resolution  sheets  using  special  printer 
ribbons.  This  program  called  SC. EXE  made  the  coding  and 
debugging  of  scanner  programs  more  efficient. 

2.4.3  OUTPUT  DESIGN 

The  scanner  in  operation  sent  an  output  record  to 
the  IBM  XT.  This  record  served  as  input  to  the  Basic 
programs,  and,  therefore,  details  of  its  format  were 
essential.  Records  were  designed  to  be  as  consistent  as 
possible  to  make  programming  and  testing  easier.  The 
following  table  lists  the  fields  of  the  scanner  record 
and  their  positions: 


SCANNER  OUPUT  RECORD  FORMAT 


FORM  TYPE 


DESCRIPTION 

1 

z 

3 

SIZE 

POSITION 

NOTES 

HEADER 

X 

X 

X 

21 

1-21 

Provided  by  scanner 

LITHO 

X 

X 

X 

8 

22-29 

CLINIC  PFX 

X 

X 

X 

1 

30 

(1-5) 

CLINIC  CODE 

X 

X 

X 

3 

31-33 

Alphabetic 

OTHER  UCA 

X 

X 

X 

1 

34 

No.  of  responses  may  vary 

TODAYS  DATE 

X 

X 

X 

4 

35-38 

MoDa 

PROV  1  PFX 

X 

X 

X 

1 

39 

Alphabetic 

PROV  1  CODE 

X 

X 

X 

4 

40-43 

Numeric 

SSN 

X 

X 

X 

9 

44-52 

Numeric 

FMP 

X 

X 

X 

2 

53-54 

Numeric 

VISIT  COUNT 

X 

X 

X 

1 

55 

(1-9)  1  Counts  as  zero 

PROV  1  TIME 

X 

X 

X 

2 

56-57 

(1-22) 

PROV  2  PFX 

X 

X 

X 

1 

58 

Alphabetic 

PROV  2  CODE 

X 

X 

X 

4 

59-62 

Numeric 

PROV  2  TIME 

X 

X 

X 

2 

63-64 

(1-22) 

REASON  FOR  #2 

X 

X 

X 

1 

65 

(1-6)  (Extra  bubble  on  psy) 

IF  NOT  SCHED 

X 

X 

X 

1 

66 

(1-2) 

IF  NOT  CLINIC 

X 

X 

X 

1 

67 

(1-6) 

REF  CODE  PFX 

X 

X 

X 

1 

68 

(1-6) 

REF  CODE 

X 

X 

X 

3 

69-71 

Alphabetic 

JOB  RELA"’ED 

X 

X 

F 

1 

72 

F  -  filler 

MIL  ONLY  DUTY 

X 

X 

F 

1 

73 

(1-2) 

MIL  ONLY  QTRS 

X 

X 

F 

1 

74 

(1-3) 

MIL  ONLY  PROF 

X 

X 

F 

1 

75 

(1-4) 

FILLER 

F 

F 

F 

5 

76-80 

Used  for  ref  codes  on  65,68 

SPEC  PRE  CLIN 

X 

X 

X 

9 

81-89 

Array 

NOT  AVAILABLE 

X 

X 

X 

3 

90-92 

Array 

PROV  2  ADDL  I 

X 

X 

X 

1 

93 

(1)  zero  by  default 

ADDL  PROC  I 

X 

X 

X 

5 

94-98 

Numeric 

PROV  2  ADDL  II 

X 

X 

X 

1 

99 

(1)  zero  by  default 

ADDL  PROC  II 

X 

X 

X 

5 

100-104 

Numeric 

ADMITTED 

X 

X 

X 

1 

105 

(1)  May  be  filler 

UNL  REAS  PRIM 

X 

X 

X 

1 

106 

(1-2)  Prefix 

UNL  REAS  PRIM 

X 

X 

X 

5 

107-111 

Dx  code 

UNL  REAS  SEC 

X 

X 

X 

1 

112 

(1-2)  Prefix 

UNL  REAS  SEC 

X 

X 

X 

5 

113-117 

Dx  code 

FOLLOW/R  OUT 

X 

X 

X 

1 

118 

(1-2) 

PROC  PROV  1 

X 

X 

X 

N 

119-118+N 

Array  with  N  procedures 

PROC  PROV  2 

X 

X 

X 

N 

119+N-118+2N  Array  with  N  procedures 

OTHER  CODES 

X 

X 

X 

P 

119+2N-118+2N+P  Array  with  N  codes 

DX  1  COL  1 

X 

X 

X 

2 

119+2N+P- 

120+2N+P  Col  position 

DX  1  COL  2 

X 

X 

X 

2 

121+2N+P- 

122+2N+P  Col  position 

DX  1  COL  3 

X 

X 

X 

2 

123+2N+P- 

124+2N+P  Col  position 

DX  1  COL  4 

X 

X 

X 

2 

125+2N+P- 

126+2N+P  Col  position 

DX  2 

X 

X 

X 

M 

127+2N+P- 

126+2N+M+P  Array  with  M  dx 

PSYCHOMETRIC  Only 

on 

Psycol  4 

127+2n+P+M-130+2n+M+P  Array 

SPEC  PROGRAMS 

F 

X 

F 

7 

Array  (note  fillers) 

The  forms  were  grouped  into  three  categories.  All 
forms  in  each  category  had  the  same  number  of  fields. 
When  a  form  did  not  have  a  field,  a  blank  or  filler  was 
provided  on  the  scanner  output  record.  These  are 
indicated  by  an  F  in  the  table.  Fields  of  varying 
length,  such  as  the  one  for  procedures,  were  placed  near 
the  end  of  the  record. 

2.5  DESCRIPTION  OF  THE  SC  PROGRAM 

The  SC. EXE  program  provided  by  NCS  to  preslug 
resolution  sheets  was  not  a  standard  program  at  that 
time.  As  a  result,  little  documentation  was  provided. 
Operation  of  the  program  had  to  be  determined; 
therefore,  some  details  in  the  operation  of  the  SC 
program  are  provided  here. 

2.5.1  OPERATION  OF  THE  SC  PROGRAM 

The  SC  program  could  be  loaded  onto  a  floppy 
diskette  or  hard  disk  and  called  by  typing  'SC*.  The 
program  first  requested  an  output  file  name.  This  was 
the  name  of  a  file  that  contained  the  data  needed  to 
preslug  the  resolution  sheets.  This  file  could  be 
copied  using  DOS.  The  SC  program  allowed  an  option  to 
edit  fields  or  add  new  resolution  sheet  boxes. 

Correcting  or  modifying  the  file  could  also  be  done  by 
an  independent  editor.  In  fact,  an  independent  editor 
was  necessary  since  the  DISPLAY  field  was  not  handled  by 
the  SC  program.  The  DISPLAY  field  provided  the  scanner 
with  the  box  containing  the  form  Litho  or  serial  number 
information.  This  Litho  number  could  then  be  sent  to 
the  IBM  computer  to  be  used  as  an  identifier  in  error 
listings. 

Although  external  editing  of  the  SC  files  was 
permitted,  care  had  to  be  taken  as  the  SC  program  did 
some  things  automatically.  One  such  process  was  the 
calculation  of  the  character  count  for  each  form.  The 
character  count  was  calculated  and  placed  in  the  last 
line  of  the  file.  Also,  the  character  count  had  to  be 
edited  if  any  box  was  modified  in  such  a  way  as  to 
change  the  character  count. 

WARNING;  The  SC  program  is  not  sophisticated  in 
reading  its  own  files.  It  determines  lines  by  counting 
characters.  Thus  every  line  in  an  SC  file  must  be  46 
characters  long.  Some  editors  may  remove  trailing 
blanks  on  a  line,  causing  the  SC  program  to  misread  the 
file. 


The  SC  program  is  menu  driven  and,  for  one  with 
some  knowledge  of  resolution  sheet  programming,  is 
fairly  user  friendly.  Some  fields  are  coded,  and  these 
are  listed  below  to  permit  reading  of  the  SC  output 
files  contained  in  this  documentation. 

2.6  SC  CODES 


The  following  codes  were  used  in  the  SC  program  when 


entering 

resolution 

sheet  information. 

These  codes 

were  provided  on  the 

screen 

menu  during 

operation. 

CLASS 

CODE 

EDIT 

CODE 

S  10 

A 

0 

C 

1 

N  11 

N 

1 

C/B 

2 

R 

2 

M 

3 

RD 

3 

LJ 

4 

IF  ERROR  CODE 

B 

4 

RJ 

5 

STOP  1 

BD 

5 

10 

6 

FLAG  2 

D 

6 

PY 

7 

SEL&REJ  3 

L 

7 

PS 

8 

SEL&FLAG  4 

F 

8 

L 

9 

2.7  FORMAT  OF  SC  FILES 

There  were  several  types  of  records:  Header,  Box, 
V#  Filler,  and  Trailer.  Formats  of  each  type  are  given 

below: 


HEADER  RECORD  1 


POSITION 

DESCRIPTION 

1 

Record  type  H 

2-3 

Skunk  Mark  count 

4-5 

Timing  Mark  count 

6-9 

Bias  Bar  (Track  and  Cell  count) 

10 

Booklet  Sequence  Check 

11 

Output  Control  Fields 

12-14 

Display  Page 

15 

Display  Box 

16-46 

Program  Notes 

HEADER  RECORD 

2 

POSITION 

DESCRIPTION 

1 

Record  type  H 

2-3 

First  Skunk  Mark  Position 

4-5 

Second  Skunk  Mark  Position 

Additional 

Skunk  Mark  Positions  as  needed. 
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BOX  RECORD 


POSITION 

DESCRIPTION 

1 

Record  type  B 

2-19 

Box  Notes 

20 

Class 

21-22 

X  Starting  Coordinate 

23-24 

X  Ending  Coordinate 

25-26 

X  Spacing 

27-28 

Y  Starting  Coordinate 

29-30 

Y  Ending  Coordinate 

31-32 

Y  Spacing 

33-34 

Edits 

35 

If  Error 

36 

Horizontal/Vertical 

37-40 

Number  of  Responses  in  Box 

41-42 

Number  of  Characters 

43-46 

Box  Number 

FILLER  RECORD 

(Leaves  an  unused  box) 

POSITION  DESCRIPTION 

1  Record  type  F 

Remaining  positions  same  as  BOX  RECORD  except 
that  positions  2-42  are  ignored  by  the  program. 


TRAILER  RECORD 

POSITION  DESCRIPTION 

1-5  Contains  //EOF 

6-9  Character  count 


2.8  LISTINGS  OF  SC  FILES 

Documentation  of  resolution  sheets  is  provided  by 
listing  the  SC  files  since  they  take  up  less  space  than 
the  resolution  sheets.  The  SC  files  are  in  Appendix  A. 

2.9  COMPILING  RESOLUTION  SHEETS 

Compilation  of  the  resolution  sheets  was  done  on 
the  NCS  7000  series  scanners.  An  'IDENTIFICATION  SHEET' 
form  was  placed  at  the  beginning  of  the  resolution 
sheets  for  each  program.  The  beginning  form  had  to  be 
coded  with  the  program  number  and  a  character  count. 

The  character  count  could  be  obtained  from  the  last  line 
of  the  SC  file  or  by  manually  summing  the  character 
responses  for  each  box  on  the  resolution  sheets.  Care 
should  be  taken  not  to  confuse  response  count  with 


character  count.  The  following  example  explains  the 
difference.  In  reading  a  Social  Security  number  of  nine 
digits,  nine  columns  of  bubbles  are  required.  Each 
column  must  have  ten  digits,  0  through  9.  Thus  there 
are  90  responses  but  the  final  result  is  nine 
characters.  The  nine  characters  are  what  is  counted  for 
the  character  count. 

The  character  count  is  important  in  that  the 
program  will  not  compile  unless  this  number  is  correct. 
An  'OPERATION  HEADER/TRAILER'  form  fellows  each  set  of 
resolution  sheets. 

The  scanner  was  turned  on  and  set  to  the  COMPILE 
mode  using  the  select  button.  A  properly  formatted 
diskette  was  inserted  into  the  disk  drive  of  the 
scanner.  The  resolution  sheets  with  the  IDENTIFICATION 
sheet  and  TRAILER  sheet  were  placed  face  down  in  the 
input  hopper.  The  start  button  was  pressed.  The 
compliled  program  was  then  written  to  the  diskette.  The 
compiler  detected  some  errors  as  each  sheet  was 
scanned.  The  sheets  could  be  corrected  and  placed  back 
into  the  input  hopper  without  restarting.  If  the 
character  count  was  incorrect,  determination  could  be 
made  to  see  if  the  count  was  incorrect  or  if  a  box  was 
coded  improperly,  resulting  in  a  false  count.  If  the 
program  compiled  correctly,  the  last  sheet  hesitated 
several  times  before  being  released  to  the  output 
hopper. 

Compilations  were  slow,  and  debugging  could  be 
tedious.  The  preslugged  forms  could  be  misread  if  a 
slight  misalignment  occurred  or  if  the  ribbon  was  worn 
or  shelf  life  had  exceeded  six  months.  The  scanner  had 
to  be  properly  maintained  to  read  the  resolution  sheets 
efficiently.  Some  hints  to  make  this  operation  easier 
are  (l)  make  sure  the  printer  ribbon  is  new  and  the 
forms  are  aligned  properly,  (2)  wipe  the  read  heads  on 
the  scanner  to  insure  they  are  clean,  (3)  vacuum  any 
dust  that  may  be  present  in  the  scanner  read  path,  (4) 
make  sure  the  environment  of  the  scanner  and  forms  has 
low  humidity.  Should  a  form  be  misread  because  of  light 
bubbles,  darken  the  bubbles  with  a  pencil  and  rescan. 

2.10  COPYING  SCANNER  DISKETTES 

Once  programs  were  compiled,  they  resided  on 
several  diskettes.  The  number  of  programs  on  one 
diskette  depended  on  the  length  of  the  program.  About 
12-14  programs  fit  on  one  diskette  based  on  the  forms 
used  in  the  ACDB  Study.  These  diskettes  had  to  be 
copied  and  sent  to  each  site  involved  in  the  study.  A 
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diskette  copy  utility  was  available  on  the  scanner. 
However,  because  there  was  only  one  drive  and  because 
the  scanner's  computer  memory  was  small,  several 
exchanges  of  the  source  diskette  and  target  diskette 
were  necessary. 

2.11  DISTRIBUTION  OF  DISKETTES  TO  SITES 

Copies  of  the  scanner  program  diskettes  were  sent 
by  mail  to  each  site  involved  with  the  study. 

Corrections  to  any  program  on  a  diskette  required  a  new 
copy  of  the  entire  diskette  to  be  sent  out.  An 
exception  to  copying  diskettes  for  all  sites  is 
discussed  in  section  2.12. 

2.12  SCANNER  SPEED 

One  of  the  several  features  of  the  7006  model 
scanner  was  that  it  could  scar,  forms  at  a  faster  rate 
than  the  7001  or  7004  models.  To  do  this,  however,  the 
progams  had  to  be  compiled  on  a  7006  scanner.  To 
achieve  the  maximum  scan  rate,  the  resolution  forms  were 
sent  to  the  Brooke  Army  Medical  Center  (BAMC)  system 
administrator.  The  programs  were  compiled  on  the  7006 
scanner  at  BAMC  and  copies  were  sent  to  all  sites  having 
the  7006  scanner. 

2.14  REFERENCES 

BASIC/PASCAL  Tabletop  Utilities  User's  Guide  for  the 
Tabletop  Scanners.  (1984).  Minneapolis,  MN:  National 
Computer  Systems,  Inc. 

Operations  Self  Instruction  Manual  for  the  Tabletop 
Scanners.  (1983).  Minneapolis,  MN;  National  Computer 
Systems,  Inc. 


User  Reference  Manual  for  the  Tabletop  Scanners. 
(1984) .  Minneapolis,  MN:  National  Computer  Systems, 
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3.0  SCANNER  IBM  XT  SYSTEM 

3.1  OVERVIEW  OF  SCANNER  IBM  XT  SYSTEM 

An  IBM  XT  system  was  used  in  conjunction  with  an 
NCS  scanner  to  read  the  ACDB  forms  and  create  a  data  set 
containing  the  output  data. 

The  first  system  had  only  one  XT  which  also  served 
as  a  data  base  management  system  using  FOCUS.  The  data 
base  management  system  required  so  much  time  in  loading, 
dumping,  reporting  and  other  operations  such  as  report 
program  development  that  there  was  not  enough  time  left 
to  scan  forms.  Thus  after  a  year  of  operation,  a  second 
XT,  which  had  a  specific  task  of  controlling  the  scanner 
and  preparing  the  data  for  loading  into  the  DBMS  was 
added  to  the  system.  The  second  XT  was  added  to  all 
sites  except  Redstone  where  the  quantity  of  data  was 
smaller  than  at  the  other  sites.  This  exception  added 
to  the  development  work  in  that  a  new  system  was  added 
to  the  extra  XTs  while  Redstone  had  to  remain  on  the  old 
system.  Later  modifications  had  to  be  specially 
customized  for  Redstone. 

3.2  EQUIPMENT 

The  additional  IBM  XT  was  installed  at  all  sites 
except  Redstone  during  the  months  of  October  and 
November  1986.  The  system  consisted  of  an  IBM  XT  with  a 
monochrome  monitor  and  256K  of  memory,  an  AST  Sixpakplus 
board  with  384K  of  memory,  which  brought  the  total 
memory  to  64 OK,  and  an  Iomega  Bernoulli  20M  byte  single 
disk  drive.  DOS  Version  3.1  was  installed. 

3.3  FUNCTIONAL  DESCRIPTION 

The  NCS  scanners  were  connected  to  an  IBM  XT  system 
using  an  RS232  cable  via  the  second  serial  port. 

Although  the  scanner  had  a  built-in  computer  that 
performed  some  editing,  the  XT  could  perform  more 
sophisticated  editing.  This  editing  was  done  in  several 
programs  written  in  IBM  Compiled  Basic.  These  programs 
read  each  scanner  output  record,  edited  the  data, 
notified  the  scanner  when  the  data  was  unacceptable, 
converted  data,  performed  table  lookups  and  created  an 
ASCII  file  as  output.  Data  in  the  output  file  could  be 
accumulated  until  the  operator  loaded  it  into  the  data 
base.  The  output  file  was  then  dumped  onto  a  20M  byte 
Iomega  cartridge  which  could  be  moved  to  the  data  base 
management  system  for  loading. 

A  login  procedure  was  necessary  to  prevent 


-11- 


unauthorized  access  to  the  system.  After  logging  on, 
the  operator  was  guided  through  the  options  available  on 
the  system  by  a  system  of  menus. 


3.3.1  PROGRAMMING  DESIGN 

The  Basic  programs  to  edit  the  scanner  output 
record  were  written  to  be  as  generic  as  possible.  The 
first  phase  of  the  study  had  a  Basic  program  for  every 
form.  After  the  redesign  of  the  forms,  one  program  was 
written  to  edit  forms  400  through  790.  Writing  and 
testing  one  program  was  less  time  consuming,  and 
maintenance  was  easier.  Previously,  when  a  universal 
change  had  to  be  made,  all  programs  had  to  be  modified, 
tested,  and  sent  out  to  the  study  sites.  Combining  a 
number  of  forms  into  one  general  program  did  have  risks, 
however,  since  a  change  to  fix  a  problem  on  one  form 
could  affect  others  without  it  being  known.  Thorough 
testing  was  required  to  prevent  this  kind  of  error. 

3. 3. 1.1  INPUT  RECORD 

After  reading  a  form,  the  scanner  sent  the  output 
record  to  the  IBM  XT.  Details  of  the  scanner  output 
record  are  in  Section  2.4.3.  In  the  XT  a  Basic  program 
read,  decoded  and  edited  the  scanner  record.  General 
algorithms  were  written  in  the  Basic  programs  to  read 
and  decode  various  sections  of  a  form  such  as  the 
procedure  list  and  diagnosis  list.  The  following  table 
contains  parameters  used  in  these  algorithms: 


PARAMETERS  FOR  BASIC  PROGRAMS 


NO. 

FORM 

TYPE 

REC 

LEN 

NO. 

PROC 

NO. 

OTHR 

NO. 

COL 

IDX 

COL 

2DX 

COL 

3DX 

COL 

4DX 

COL 

DX2 

OFF 

200 

PATIENT  REGISTRATION 

U 

300 

PROVIDER  REGISTRATION 

U 

400 

ADOLESCENT  MEDICINE 

3 

303 

28 

4 

34 

35 

30 

24 

-2 

410 

ALLERGY 

1 

276 

43 

3 

17 

19 

31 

-1 

420 

AUDIOLOGY/SPEECH 

1 

291 

49 

3 

31 

28 

11 

-1 

430 

CARDIOLOGY 

1 

323 

29 

4 

43 

34 

33 

30 

-1 

440 

CARDIOTHORACIC  SURGERY 

1 

276 

15 

4 

37 

28 

28 

27 

0 

450 

DERMATOLOGY 

1 

466 

92 

4 

42 

43 

44 

28 

-1 

460 

ENDOCRINE 

1 

205 

10 

3 

18 

18 

26 

-1 

470 

ENT 

1 

305 

41 

4 

25 

37 

20 

16 

-1 

480 

FAMILY  PRACTICE 

1 

315 

16 

4 

48 

41 

42 

28 

-2 

490 

GASTROENTEROLOGY 

1 

293 

29 

3 

33 

40 

39 

-1 

500 

GENERAL  SURGERY 

1 

322 

36 

4 

26 

35 

42 

22 

-1 

510 

GYNECOLOGY 

1 

406 

58 

4 

44 

44 

46 

32 

-2 

520 

INFECTIOUS  DISEASE 

1 

230 

17 

3 

30 

24 

19 

-1 
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REC 

NO. 

NO. 

NO. 

IDX 

2DX 

3DX 

4DX 

DX2 

NO. 

FORM  TYPE 

LEN 

PROC 

OTHR 

COL 

COL 

COL 

COL 

COL 

OFF 

530 

INTERNAL  MEDICINE 

1 

230 

13 

4 

25 

27 

18 

10 

-2 

540 

NEPHROLOGY 

1 

380 

64 

24 

4 

31 

37 

18 

17 

-1 

550 

NEUROLOGY 

1 

371 

17 

4 

59 

62 

50 

41 

-1 

560 

NEUROSURGERY 

1 

393 

20 

29 

4 

60 

62 

61 

17 

-2 

570 

NUCLEAR  MEDICINE 

1 

580 

NUTRITION  CARE 

3 

310 

38 

3 

42 

38 

32 

-2 

590 

OBSTETRICS 

1 

307 

44 

4 

25 

24 

34 

12 

-2 

600 

ONCOLOGY/HEMATOLOGY 

3 

321 

24 

4 

40 

35 

39 

34 

-1 

610 

OPHTHAMOLOGY 

1 

314 

41 

4 

30 

28 

32 

18 

-2 

620 

OPTOMETRY 

1 

353 

51 

21 

4 

34 

30 

26 

16 

-2 

630 

ORTHO  APPLIANCE/CAST 

3 

334 

41 

107 

2 

12 

11 

0 

640 

ORTHOPEDICS 

1 

309 

25 

4 

35 

43 

33 

23 

-1 

650 

OCCUPATIONAL  THERAPY 

1 

469 

120 

4 

28 

31 

31 

15 

-2 

660 

PAIN/PHYSICAL  MEDICINE 

1 

325 

50 

3 

38 

43 

21 

-1 

670 

PEDIATRICS 

3 

336 

40 

4 

25 

45 

37 

25 

-2 

680 

PHYSICAL  THERAPY 

1 

373 

65 

19 

4 

37 

34 

17 

12 

-2 

690 

PLASTIC  SURGERY 

1 

270 

22 

4 

22 

27 

26 

26 

-1 

700 

PODIATRY 

1 

324 

51 

3 

18 

42 

39 

-1 

710 

PREVENTIVE  MEDICINE/CHN 

1 

351 

55 

4 

32 

31 

34 

20 

-2 

720 

PRIMARY  CARE 

1 

254 

12 

4 

34 

29 

28 

15 

-2 

730 

PSYCHIATRY 

2 

362 

10 

30 

4 

60 

52 

55 

14 

-2 

740 

PSYCHOLOGY  (4  PSY  ASSM) 

2 

396 

38 

34 

3 

52 

40 

59 

0 

750 

PULMONARY 

1 

285 

36 

3 

40 

25 

25 

-1 

760 

RADIOTHERAPY 

3 

770 

RHEUMATOLOGY 

1 

284 

9 

11 

4 

36 

32 

34 

28 

-1 

780 

SOCIAL  WORK 

2 

317 

34 

1 

4 

30 

35 

29 

22 

-1 

790 

UROLOGY 

1 

324 

56 

4 

19 

23 

33 

12 

-1 

800 

BAS/TMC 

U 

330 

25 

4 

37 

30 

42 

40 

-2 

810 

EFMP 

U 

820 

EKG 

U 

239 

18 

830 

EMERGENCY  ROOM 

U 

461 

71 

4 

55 

63 

50 

26 

-1 

840 

GROUP  FORM  I 

U 

95 

98 

850 

GROUP  FORM  II 

U 

194 

860 

IMMUNIZATION  SHORT 

U 

397 

39 

870 

INDIVIDUAL  MEDICAL  READ 

U 

880 

INHALATION  THERAPY 

U 

890 

NUTRITION  CARE  SHORT 

u 

900 

OCCUPATIONAL  HEALTH 

u 

534 

81 

20 

4 

33 

36 

39 

26 

-1 

910 

OCCUPATIONAL  THER  REP 

u 

352 

26 

20 

PHYSICAL  THERAPY  REPEAT 

u 

352 

26 

>3  0 

REPEAT 

u 

118 

940 

SHORT 

u 

252 

16 

950 

SOCIAL  WORK  SHORT 

u 

183 

5 
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The  above  table  was  constructed  during  program 
development  and  can  be  used  as  a  guide  for  developing 
new  forms  or  debugging  problems.  An  explanation  of  the 
table  follows: 

Program  Number 

The  first  column  contains  an  arbitrary  program 
number.  This  number  is  used  by  the  scanner  and  XT 
to  identify  programs  and  tables  belonging  to  each 
form. 

Form 

The  second  column  provides  the  form  description. 

Form  Type 

The  form  type  generally  categorizes  the  forms  into 
similar  groups  based  on  the  design  of  the  form. 

There  are  three  general  types  (1-3)  and  a  number  of 
unique  types  designated  by  'U'. 

Record  Length 

The  record  length  shown  in  the  fourth  column  is  the 

most  important  parameter  in  the  table.  It  is  the  • 

length  of  the  scanner  record  being  sent  to  the  XT. 

The  length  includes  21  characters  in  a  header  plus 
the  character  count  from  the  scanner  program.  A 
formula  used  to  determine  the  length  of  the  record 
based  on  the  other  parameters  for  the  general  form 
types  is  given  below: 

L  =  118  +2N+P+2C+M+F 

where  L  is  the  record  length 

N  is  the  number  of  procedures 
P  is  the  number  of  other  codes 
C  is  the  number  of  diagnosis  columns 
M  is  the  total  number  of  diagnoses 
F  is  the  Dx2  offset 

Each  scanner  program  was  designed  to  output  an 
identical  section  of  the  record  which  totaled  118 
characters.  Blank  fillers  were  used  for  those 
fields  not  present  on  a  form. 

Number  of  Procedures 

The  fifth  column  of  the  table  lists  the  number  of 
procedures  present  on  each  form. 
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Number  of  Other  Codes 

Several  forms  have  sections  that  are  similar  to  the 
procedure  list  but  are  not  procedures.  They  have 
been  given  the  generic  name  of  'Other  Codes. ' 

Column  six  in  the  table  shows  the  number  of  'Other 
Codes'  on  each  form. 

Number  of  Columns 

The  diagnosis  section  on  each  form  is  broken  up 
into  columns.  The  seventh  column  in  the  table 
indicates  the  number  of  columns  on  each  form. 

Number  of  Diagnoses  in  a  Column 

The  four  columns  labeled  IDX  COL,  2DX  COL,  3DX  COL 
and  4DX  COL  contain  the  number  of  diagnoses  in  each 
column  present  on  a  form. 

Secondary  Diagnosis  Offset 

There  are  generally  two  bubbles  beside  each 
diagnosis  description  on  a  form,  one  for  the 
primary  diagnosis,  and  one  for  the  secondary 
diagnosis.  Where  the  last  one  or  two  diagnoses 
indicate  'no  problem  noted'  or  some  similar 
description,  no  secondary  bubble  is  present.  The 
last  column  of  the  table  indicates  the  number  of 
entries  for  diagnoses  that  have  no  secondary 
bubble.  In  other  words,  the  total  number  of 
primary  diagnoses  on  a  form  would  be  the  sum  of  the 
entries  from  the  IDX,  2DX,  3DX,  and  4DX  columns, 
and  the  total  number  of  secondary  diagnoses  would 
be  the  same  number  plus  the  offset. 

.3.1.2  OUTPUT  RECORD 

After  a  form  was  read  by  the  scanner  and  edited  by 
a  Basic  program  it  was  either  accepted  or  rejected.  The 
rejected  forms  were  sent  to  a  reject  hopper  on  the 
scanner  and  could  be  corrected  by  the  study 
administrator  or  sent  back  to  the  clinic.  The  Basic 
program  provided  a  listing  of  the  serial  numbers  (litho 
code)  of  the  rejected  forms  and  described  the  errors 
found  on  each  form. 

The  data  from  accepted  forms  was  then  written  to  an 
ASCII  file  for  later  inclusion  in  the  FOCUS  data  base. 
Several  types  of  records  were  written  so  FOCUS  could 
loaJ  the  data  into  its  hierarchical  structure.  The 
following  table  describes  the  formats  of  these  output 
records : 
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BASIC  PROGRAM  OUTPUT  RECORD  FORMAT 


RECORD  TYPE  1  GENERAL  WITH  PRIMARY  DX 


FIELD 

SIZE 

POSITION 

NOTES 

PROGRAM  ID 

3 

1-3 

RECORD  TYPE 

1 

4 

CODED  AS  1 

CLINIC  ID 

4 

5-8 

VISIT  DATE 

6 

9-14 

PRIM  PROV 

5 

15-19 

RECORD  KEY 

SSN 

9 

20-28 

COMMON  TO  ALL 

FAM  MEM  PFX 

2 

29-30 

RECORD  TYPES 

LITHO 

8 

31-38 

FORM  NUMBER 

2 

39-40 

- 1 

VISIT  COUNT 

1 

41 

PRI  PROV  TIME 

3 

42-44 

SEC  PROV 

5 

45-49 

SEC  PROV  TIME 

3 

50-52 

REAS  FOR  SEC  PROV  1 

53 

APPOINTMENT  ST AT  1 

54 

REFERRAL  CODE 

4 

55-58 

PLACE  OF  VISIT 

1 

59 

JOB  REL  VISIT 

1 

60 

MIL  DUTY 

1 

61 

MIL  QTR 

1 

62 

MIL  PROFILE 

1 

63 

NOT-AVAILABLE 

1 

64 

ADMITTED 

1 

65 

INFIELD 

1 

66 

INJURIES 

1 

67 

PURPOSE  OF  VISIT  1 

68 

PRIM  DX  RULE  OUT  1 

69 

PRIM  DX 

5 

70-74 

PADDING 

6 

75-80 

RECORD  TYPE  2  PROCEDURE  CODE 


FIELD 

SIZE 

POSITION 

NOTES 

PROGRAM  ID 

3 

1-3 

RECORD  TYPE 

1 

4 

CODED  AS  2 

RECORD  KEY 

36 

5-40 

COMMON  TO  ALL  RECORD  TYPES 

PROV  INDICATOR 

1 

41 

PROCEDURE  CODE 

5 

42-46 

PADDING 

47-80 

BASIC  PROGRAM  OUTPUT  RECORD  FORMAT 


RECORD  TYPE  3  SPECIFIC  PREASSIGNEC  CLINIC  CODES 


FIELD 

SIZE 

POSITION 

PROGRAM  ID 

3 

1-3 

RECORD  TYPE 

1 

4 

RECORD  KEY 

36 

5-40 

SPE  PRE  CLINIC 
PADDING 

CD  1 

41 

42-80 

NOTES _ 

CODED  AS  3 

COMMON  TO  ALL  RECORD  TYPES 


FIELD 

RECORD 

SIZE 

TYPE  4 

POSITION 

OTHER  CODES 

NOTES 

PROGRAM  ID 

3 

1-3 

RECORD  TYPE 

1 

4 

CODED  AS  4 

RECORD  KEY 

36 

5-40 

COMMON  TO  ALL  RECORD  TYPES 

OTHER  CODES 
PADDING 

5 

41-45 

46-80 

FIELD 

RECORD 

SIZE 

TYPE  5  GROUP 

POSITION 

SEGMENT 

NOTES 

PROGRAM  ID 

3 

1-3 

RECORD  TYPE 

1 

4 

CODED  AS  5 

RECORD  KEY 

36 

5-40 

COMMON  TO  ALL  RECORD  TYPES 

UNIT  ID  CODE 

6 

41-46 

TIME  PREP  PROV 

1 

3 

47-49 

TIME  PREP  PROV 

2 

3 

50-52 

TIME  TRAV  PROV 

1 

3 

53-55 

TIME  TRAV  PROV 

2 

3 

56-58 

NO.  ACT  DUTY 

3 

59-61 

NO.  OTHER  DUTY 

3 

62-64 

NO.  RETIRED  MIL 

3 

65-67 

NO.  DEPENDANTS 

3 

68-70 

NO.  CIVILIANS 

3 

71-73 

CONTINUATION 

1 

74 

PADDING 

75-80 

BASIC  PROGRAM  OUTPUT  RECORD  FORMAT 


RECORD  TYPE  6  SPECIAL  PROGRAMS 


FIELD 

SIZE 

POSITION 

NOTES 

PROGRAM  ID 

3 

1-3 

RECORD  TYPE 

1 

4 

CODED  AS  6 

RECORD  KEY 

36 

5-40 

COMMON  TO  ALL  RECORD  TYPES 

SPECIAL  PROGRAMS  1 

41 

PADDING 

42-80 

RECORD  TYPE 

7  MULTIPLE  SECONDARY  DX 

FIELD 

SIZE 

POSITION 

NOTES 

PROGRAM  ID 

3 

1-3 

RECORD  TYPE 

1 

4 

CODED  AS  7 

RECORD  KEY 

36 

5-40 

COMMON  TO  ALL  RECORD  TYPES 

SEC  DX 

5 

41-45 

PADDING 

46-80 

RECORD  TYPE 

8  PSYCHOMETRIC  ASSESSMENT 

FIELD 

SIZE 

POSITION 

NOTES 

PROGRAM  ID 

3 

1-3 

RECORD  TYPE 

1 

4 

CODED  AS  8 

RECORD  KEY 

36 

5-40 

COMMON  TO  ALL  RECORD  TYPES 

PSYCHOM  ASSESS 

1 

41 

PADDING 

42-80 

RECORD  TYPE 

9  DISPOSITIONS 

(FROM  OCC  HEALTH  FORM) 

FIELD 

SIZE 

POSITION 

NOTES 

PROGRAM  ID 

3 

1-3 

RECORD  TYPE 

1 

4 

CODED  AS  9 

RECORD  KEY 

36 

5-40 

COMMON  TO  ALL  RECORD  TYPES 

DISPOSITION 

2 

41-42 

PADDING 

43-80 
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BASIC  PROGRAM  OUTPUT  RECORD  FORMAT 


RECORD  TYPE  A  GROUP  II  DATA 


■1 V 

POSITION 

NOTES 

PROGRAM  ID 

3 

1-3 

RECORD  TYPE 

1 

4 

CODED  AS  A 

RECORD  KEY 

36 

5-40 

COMMON  TO  ALL  RECORD  TYPES 

SSN 

9 

41-49 

FMP 

2 

50-51 

PADDING 

52-80 

t* 


3 . 4  PROGRAMS 

The  programs  in  the  IBM  XT  Scanner  System  were 
written  in  the  BASIC  language  for  the  IBM  Basic  Compiler 
Version  1.0. 

A  list  of  compiled  BASIC  programs  and  their 
functions  follows: 

RACP05.EXE  Initial  sign  on  program. 

RACP10.EXE  Main  menu  program. 

RACP1A.EXE  Scanner  form  program  select. 

RACPGEN.EXE  General  decode  program  for  forms  400-790. 
RACP200.EXE  Decode  prog,  for  form  200  (Patient  reg.) 

RACP300.EXE  Decode  prog,  for  form  300  (Provider  reg) 

RACP800.EXE  Decode  prog,  for  form  800  (BAS/TMC) 

RACP820.EXE  Decode  prog,  for  form  820  (EKG) 

RACP830.EXE  Decode  prog,  for  form  830  (Emergency  rm) 

RACP850.EXE  Decode  ptog.  for  forms  840-850  (Group) 
RACP860.EXE  Decode  prog,  for  form  860  (Immun.  Short) 

RACP900.EXE  Decode  prog,  for  form  900  (Occ  Health) 

RACP910.EXE  Decode  prog,  for  form  910  (OT  Repeat) 

RACP920.EXE  Decode  prog,  for  form  920  (PT  Repeat) 

RACP930.EXE  Decode  prog,  for  form  930  (Repeat) 

RACP940.EXE  Decode  prog,  for  form  940  (Short) 

RACP950.EXE  Decode  prog,  for  form  950  (Soc  Wk  Short) 

Compiled  programs  all  have  the  EXE  extension.  The 
source  programs  have  a  BAS  extension.  Listings  of  the 
compiled  programs  have  an  LST  extension.  Program 
listings  can  be  found  in  the  appendix.  Compiled 
programs  may  contain  subroutines  that  are  common  to  more 
than  one  program.  While  specific  subroutine  listings 
are  not  provided  in  this  documentation,  the  compiled 
versions  of  the  subroutines  are  included  with  each 
program  listing.  The  names  of  the  subroutines  and  their 
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functions  are  shown  below. 

RACDIM.MOD  Dimension  Definitions. 

RACCNN.MOD  Common  Area  Definitions. 

RACDEF.MOD  Default  Definitions. 

RACSIOOO.SUB  Logon  verification. 

RACS2000.SUB  Wait  and  Reply. 

RACS5000.SUB  Date  editor 

RACS5700.SUB  Map  ones  to  position. 

RACS5800.SUB  Four  col  Dx  converter. 

RACS6000.SUB  Instring  search. 

RACS7000.SUB  Screen  header  display. 

RACS7100.SUB  Print  standard  heading. 

RACS8000.SUB  Scanner  decoder. 

RACS9000.SUB  Scanner  I/O  controller. 

RACS9010.SUB  Scanner  control  options. 

RACS9020.SUB  Scanner  sheet  call. 

RACS9030.SUB  Scanner  transport  print  call. 

Two  other  subroutines  used  in  programs  reading 
forms  were  RACMnnn.MOl  and  RACMnnn.M02  where  nnn  is  the 
form  number.  The  corresponding  subroutine  names  for  the 
general  form  program  are  RACREAD.MOD  and  RACWRIT.MOD. 

The  first  subroutine  decoded  and  converted  data  as  well 
as  performed  editing  functions.  The  second  subroutine 
wrote  the  output  records  to  an  ASCII  file. 

The  procedure  and  diagnosis  codes  for  each  form 
were  typed  into  separate  files  and  were  read  by  the 
program  to  be  used  for  table  lookups.  Each  file  began 
with  a  blank  code  and  ended  with  a  code  of  five  'Z's. 

All  codes  were  five  characters  and  enclosed  in  quotes. 
Diagnosis  codes  less  than  five  characters  were  padded 
with  blanks.  Each  file  had  an  extension  corresponding 
with  the  form  number.  Files  were  named  RACDIAG  or 
RACPROC  depending  on  whether  they  were  diagnosis  codes 
or  procedure  codes.  The  names  of  all  table  files  are 


RACDIAG. 400 
RACDIAG. 410 
RACDIAG. 420 
RACDIAG. 430 
RACDIAG. 440 
RACDIAG. 450 
RACDIAG. 460 
RACDIAG. 470 
RACDIAG. 480 
RACDIAG. 490 
RACDIAG. 500 
RACDIAG. 510 
RACDIAG. 520 
RACDIAG. 530 


RACDIAG. 620 
RACDIAG. 630 
RACDIAG. 640 
RACDIAG. 650 
RACDIAG. 660 
RACDIAG. 670 
RACDIAG. 680 
RACDIAG. 690 
RACDIAG. 700 
RACDIAG. 710 
RACDIAG. 720 
RACDIAG. 730 
RACDIAG. 740 
RACDIAG. 750 


RACPROC. 400 
RACPROC. 410 
RACPROC. 420 
RACPROC. 430 
RACPROC. 440 
RACPROC. 450 
RACPROC. 460 
RACPROC. 470 
RACPROC. 480 
RACPROC. 490 
RACPROC. 500 
RACPROC. 510 
RACPROC. 520 
RACPROC. 530 


RACPROC. 620 
RACPROC. 630 
RACPROC. 640 
RACPROC. 650 
RACPROC. 660 
RACPROC. 670 
RACPROC. 680 
RACPROC. 690 
RACPROC. 700 
RACPROC. 710 
RACPROC. 720 
RACPROC. 730 
RACPROC. 740 
RACPROC. 750 
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RACDIAG.540 

RACDIAG.550 

RACDIAG.560 

RACDIAG.580 

RACDIAG.590 

RACDIAG.600 

RACDIAG.610 


RACDIAG.770 

RACDIAG.780 

RACDIAG.790 

RACDIAG.800 

RACDIAG.830 

RACDIAG.900 


RACPROC.540 

RACPROC.550 

RACPROC.560 

RACPROC.580 

RACPROC.590 

RACPROC.600 

RACPROC.610 


RACPROC.770 

RACPROC.780 

RACPROC.790 

RACPROC.800 

RACPROC.830 

RACPROC.900 


3.4.1  OPERATION 


The  operation  of  the  Scanner  XT  System  began  by 
invoking  a  DOS  batch  file  called  STRTACDB.  The  FOCUS  XT 
System  began  with  a  batch  file  of  the  same  name.  Each 
system  could  be  configured  by  the  AUTOEXEC.BAT  file  to 
move  to  the  proper  directory  and  automatically  call  the 
STRTACDB  batch  file.  For  those  familiar  with  DOS,  the 
operator  could  change  directories  and  type  STRTACDB  to 
enter  the  corresponding  system.  In  the  Scanner  system 
the  STRTACDB  batch  file  was  as  follows: 

ECHO  OFF 

C: 

CD  \AMB 

PATH  C:\AMB;C;\;D:\ 

CLS 

RXXP05 

RXXBOO 

C: 

CD  \ 

CLS 

The  scanner  programs  resided  in  the  AMB  directory. 
DOS  was  in  the  root  directory.  The  batch  file  changed 
directories  and  set  up  a  path.  Then  the  Basic  program 
RXXP05  was  called.  This  was  the  initial  log-on  menu 
program.  Logging  on  involved  supplying  a  password.  The 
password  was  encrypted  and  written  to  a  file  called 
RXXFPWD.FEX.  As  other  programs  in  the  system  were 
executed,  they  checked  to  see  that  a  proper  password  was 
set  before  proceeding.  When  the  operator  exited  the 
system,  the  password  file  was  emptied. 


The  RXXP05  program  wrote  information  to  a  batch 
file  called  RXXBOO.  After  completion  of  the  RXXP05 
program,  execution  was  returned  to  the  STRTACDB  batch 
file  which  then  called  the  RXXBOO  batch  file.  Other 
programs  continued  this  chain,  modifying  the  RXXBOO  file 
and  another  batch  file  called  RXXBIO  until  the  system 
was  exited  through  the  RXXB05  program.  Some  programs 
such  as  the  sort  utility  had  their  own  special  batch 
file.  These  are  explained  later. 
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3.5  OTHER  PROGRAMS 


Two  other  programs  which  resided  in  the  scanner  XT 
are  COSORT  and  SCANUTIL.  These  programs  were  acquired 
from  outside  vendors.  COSORT  was  used  to  sort  the  data 
before  loading  into  the  FOCUS  data  base  although  some  of 
these  files  were  sorted  in  the  Data  Base  XT  system. 
SCANUTIL  was  a  scanner  utility  program  provided  by  NCS 
and  used  primarily  in  development  to  examine  the  scanner 
output  records. 

3.6  COSORT 

COSORT  Version  4.1  was  a  group  of  programs  obtained 
from  Information  Resources  in  New  York.  These  programs 
are  used  to  sort  large  data  bases  efficiently.  A 
detailed  explanation  will  not  be  given  in  this 
documentation  since  there  is  a  COSORT  Version  4.1  manual 
available.  Specific  details  of  how  it  was  used  in  the 
scanner  XT  system  will  be  given. 

In  the  scanner  XT  the  COSORT  programs  were  used  to 
sort  the  provider  and  patient  registration  data  which 
had  been  scanned  and  placed  in  an  ASCII  output  file. 
Three  items  were  needed: 

1.  COSORT. COR 

2.  RECOUP.EXE 

3.  A  batch  file  with  sort  parameters. 

The  first  two  items  are  the  sort  programs  from 
Information  Resources.  The  third  item  is  a  batch  file 
customized  to  sort  the  user's  data.  Since  the  Provider 
and  Patient  files  were  to  be  sorted  in  the  scanner  XT 
system,  a  batch  file  for  each  was  needed.  They  are 


RACPRSRT . BAT 

(Provider  batch  file) 

RACPTSRT . BAT 

(Patient  batch  file) 

The 

contents  of  each 

batch  file  are  given  below 

RACPRSRT.BAT 

RACPTSRT . BAT 

1. 

sort 

sort 

2. 

ccc 

ccc 

3. 

0 

0 

4. 

1 

1 

5. 

provider.dat 

patient.dat 

6. 

1 

1 

7. 

ascending 

ascending 

8. 

fixed 

fixed 

9. 

1 

1 

10. 

17 

20 
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11. 

alpha 

alpha 

12. 

none 

none 

13. 

no 

no 

14. 

file 

file 

15. 

provider.dat 

patient.dat 

The  line  numbers  above  are  included  to  aid  in  explaining 
the  parameters  and  are  not  part  of  the  file. 

Line  1.  Type  of  operation. 

Name  of  work  disk  (repeated  three  times) . 

Record  length  (0  for  variable  length) . 

Number  of  input  files. 

Input  file  name. 

Number  of  sort  keys. 

Lines  7-13  Sort  key  parameters,  could  be  repeated 
if  more  than  one  sort  key  is  required. 

7.  Sort  direction. 

Field  locator. 

Position  of  field. 

Length  of  field. 

Character  type. 

A1 ignment . 

Case  change. 

Device  to  send  output  records. 

Name  of  output  file. 


Line  2. 
Line  3. 
Line  4. 
Line  5. 
Line  6. 


Line 
Line  8. 
Line  9. 
Line  10. 
Line  11. 
Line  12. 
Line  13. 
Line  14. 
Line  15. 


The  COSORT  program  was  called  from  the  Provider 
BASIC  program  RACP300  by  setting  up  a  batch  file  with 
the  line:  'RECOUP  RACPRSRT.BAT'  in  it.  After 
completion  the  RACP300  program  returned  to  the  batch 
file  which  in  turn  executed  the  RECOUP  program  using  the 
parameters  from  the  RACPRSRT.BAT  file.  The  Patient 
BASIC  program  called  the  sort  program  in  a  similar 
fashion. 


3.6.1  WARNING 

WARNING!  The  sort  program  can  get  in  a  loop  when 
it  runs  out  of  disk  space.  No  indication  is  given  to 
the  operator  except  the  program  continues  to  run  much 
longer  than  it  should.  The  operator  has  a  couple  of 
options  available  when  this  happens.  As  in  most  cases 
when  the  unexpected  occurs,  no  explicit  set  of  rules 
applies.  However,  the  operator  could  interrupt  the 
program  and  free  up  additional  disk  space  before 
continuing  the  program  or  the  operator  could  scan  fewer 
forms  so  that  the  file  to  be  sorted  is  smaller. 

3.7  SCANUTIL  PROGRAM 

The  SCANUTIL  program  was  provided  by  NCS  to  be  used 
in  development  of  the  scanner  system.  SCANUTIL  is  a 
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utility  program  that  can  drive  the  scanner  and  capture 
the  scanner  output  records  as  each  form  is  scanned. 

The  program  SCANUTIL.EXE  is  a  stand-alone  program 
and  is  executed  by  typing  'SCANUTIL'  at  the  DOS  prompt. 
It  is  menu  driven  and  for  the  most  part  self 
explanatory. 

3.7.1  MAIN  MENU 

The  first  menu  to  appear  is  the  MAIN  menu.  Its 
format  is  as  follows; 

COPYRIGHTED  REL  1 . 1 

NATIONAL  COMPUTER  SYSTEMS  INC. 

SCAN  UTILITY 
MAIN  MENU 

0  -  EXIT  FROM  SCAN  UTILITY 

1  -  SCAN  TO  DISK 

2  -  SCAN  TO  SCREEN 

3  -  SCAN  TO  PRINTER 

4  -  SET  UP  CONFIGURATION 

SELECT  OPTION  (0-4): 

3.7.2  CONFIGURATION  MENU 

The  configuration  had  to  be  set  up  each  time  the 
program  was  executed.  The  configuration  menu  and  the 
correct  parameters  for  the  ACDB  Scanner  XT  system  are  as 
follows; 
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COPYRIGHTED  REL  1.1 

NATIONAL  COMPUTER  SYSTEMS  INC. 


SCAN  UTILITY 
SYSTEM  CONFIGURATION 

0  -  EXIT  TO  MAIN  MENU 

1  -  SCANNING  MODE: _ OPERATOR  ACTIVATED 


2  -  DISPLAY/PRINT  FORMAT: . TEXT 

3  -  SCANNER  SERIES:  7000  OR  9000 

4  -  BAUD  RATE: . 9600 

5  -  PARITY: . NONE 

6  -  DATA  BITS : . 8 

7  -  STOP  BITS : . 1 

8  -  SERIAL  PORT: . 2 


SELECT  OPTION  (0-8): 

Items  4-8  above  had  to  be  set  each  time  the  program  was 
loaded.  By  selecting  an  option,  the  operator  would  see 
another  menu  with  choices  available  for  that  option. 

The  options  used  in  the  ACDB  system  are  BAUD  RATE  = 
9600,  PARITY  =  NONE,  DATA  BITS  =  8,  STOP  BITS  =  1  and 
SERIAL  PORT  =  2. 


3.7.3  DISPLAY  RECORD 


From  the  main  menu  the  output  could  be  displayed  on 
the  screen,  printed,  or  written  to  a  file.  Generally 
the  records  were  printed  because  close  scrutiny  of  the 
record  was  required  as  well  as  a  hard  copy  in  case  of 
future  problems.  A  sample  of  a  scanner  output  record 
printed  by  the  SCANUTIL  program  for  the  Allergy  Form 
(410)  is  shown  below: 


SCAN  UTILITY  SOURCE  SCANNER 

SHEET  RECORD  DISPLAY  RECORD  NUMBER:  1  RECORD  LENGTH:  276 


FORMAT:  TEXT 

0  12  3 

1 . 0 . 0 . 0 

4100010001101  00013936 

1  88888133333 

1  1 


4  5  6 

. 0 . 0 . 0 

0402T123498700123401  12A00 
1 

1  271 


1  1 


The  sample  is  truncated  to  fit  on  this  page.  It 
normally  extends  to  80  columns.  The  scanner  has 
converted  some  data  and  performed  some  editing  but  now 
sends  it  to  the  XT  for  further  editing  and  conversion. 
Notice  the  form  number,  410,  in  the  first  three 
characters.  The  provider  ID,  T1234,  can  be  seen  in 
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positions  39-43.  Position  details  are  provided  in 
section  2.4.3. 

3 . 8  REFERENCES 

BASIC  Compiler.  (1982)  Boca  Raton,  FL:  International 
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COSORT  Program  Manual  Version  4.1.  (1984)  Manhasset, 
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Disk  Operating  System  Version  3.1.  (1985)  Boca  Raton, 

FL:  International  Business  Corporation- 
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4.0  DATA  BASE  lEM  XT  SYSTEM 

4.1  OVERVIEW  OF  DATA  BASE  IBM  XT  SYSTEM 

An  IBM  XT  system  was  used  to  provide  storage  and 
reporting  capabilities  through  a  fourth  generation  data 
base  management  package  called  FOCUS.  Initially  FOCUS 
resided  with  the  Scanner  system,  but,  because  of  the 
large  amounts  of  time  required  to  load,  dump  and  process 
the  data,  two  changes  were  made.  The  external  disk 
drives  and  cartridges  were  increased  from  lOM  to  20M 
bytes  and  a  separate  IBM  XT  was  acquired  so  that  the 
data  base  system  could  be  run  independently.  The  data 
base  system  allowed  reports  and  other  procedures  to  be 
run  while  new  forms  were  being  scanned  on  a  separate 
system. 

4.2  EQUIPMENT 

The  data  base  management  system  consisted  of  an  IBM 
XT  with  a  lOM  byte  disk  drive,  a  color  monitor  and  256K 
of  memory.  A  memory  board  supplied  with  FOCUS  contained 
512K  of  memory,  bringing  the  total  memory  to  768K. 

Early  versions  of  FOCUS  took  advantage  of  the  memory 
above  640K.  An  Iomega  Bernoulli  20M  dual  drive  was  used 
for  data  storage.  A  Case-Rixon  model  PC212A  internal 
modem  operating  at  1200  baud  was  used  for  electronic 
mail,  however,  it  was  installed  in  either  the  scanner  or 
data  system  depending  which  was  more  convenient  to  a 
phone  line.  A  Genicom  Model  3014  printer  with  a  wide 
carriage  was  installed. 

The  FOCUS  memory  boards,  particularly  a  piggy-back 
memory  card  containing  256K  bytes,  caused  problems  after 
being  used  about  a  year.  The  clock  battery  also  seemed 
to  quit  after  a  year  of  use.  When  the  20M  byte  Iomega 
disk  drives  were  installed,  the  piggy-back  card  on  some 
FOCUS  boards  had  to  be  removed  before  the  Iomega  drive 
would  work.  The  FOCUS  board  was  essential,  however, 
since  FOCUS  versions  1.5  and  earlier  versions  had  a  copy 
protection  scheme  incorporated  within  the  board.  After 
FOCUS  version  2.0  was  installed,  any  memory  board  would 
work,  and,  in  some  cases,  AST  SIXPAK  boards  with  384K 
bytes  of  memory  were  used  as  replacements. 

In  addition  to  the  computer  system,  a  SOLA 
uninterruptable  power  supply  was  used  at  most  of  the 
sites  unless  the  equipment  was  placed  in  a  computer  room 
with  a  backup  power  supply. 
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4.3  FUNCTIONAL  DESCRIPTION 

The  forms  were  scanned  and  edited  by  the  scanner 
system.  The  data  was  written  in  flat  (ASCII)  files  on 
the  Iomega  cartridges.  These  cartridges  were  then  taken 
to  the  data  base  system  where  the  data  was  loaded  into 
the  hierarchical  data  base  called  FOCUS. 

There  were  six  separate  data  bases  that  could  be 
joined  for  reporting.  They  were  a  Provider  file,  a 
Patient  file,  a  Clinic  description  file,  a  Procedure 
description  file,  a  Diagnosis  description  file  and  a 
Visit  file.  The  Visit  file  contained  the  data  from  the 
enounter  forms  and  was  cumulated  monthly.  At  the  end  of 
each  month  reports  were  printed,  and  the  data  then 
dumped  onto  cartridges  and  sent  to  Fort  Detrick  to  be 
loaded  on  a  mainframe  computer. 

A  login  procedure  was  necessary  to  prevent 
unauthorized  access  to  the  system.  After  logging  on, 
the  operator  was  guided  through  the  available  options  by 
a  menu  system. 

4 . 4  SOFTWARE 

4.4.1  SYSTEM  SOFTWARE 

FOCUS  version  1.0  was  first  installed  as  the  data 
base  management  language.  FOCUS  1.5  soon  came  along  and 
the  system  was  upgraded.  Two  additional  upgrades  of 
FOCUS  1.5  were  installed  and  used  until  FOCUS  2.0  was 
installed.  Early  versions  of  FOCUS  had  a  number  of 
problems  which  caused  a  great  deal  of  difficulty  in 
development  efforts  as  well  as  in  providing  technical 
support  to  the  sites.  Early  documentation  was  also  very 
poor.  New  documentation  with  FOCUS  1.5  was  a 
significant  improvement,  and  each  new  version  of 
software  fixed  a  number  of  problems  present  in  the  older 
version.  Most  of  the  bugs  causing  problems  in  the  ACDB 
system  were  removed  by  the  time  FOCUS  2.0  was 
installed.  However,  at  that  time  the  system  was  using 
DOS  3.0,  and  FOCUS  2.0  seemed  to  lockup  the  system 
rather  frequently.  The  computer  had  to  be  turned  off 
and  then  on  again  to  clear  the  lockup.  FOCUS  personnel 
at  Information  Builders,  Inc.  (IBI)  could  not  resolve 
the  problem;  upgrading  to  DOS  3.1  reduced  the  lockup 
problem  considerably.  Programming  details  of  how  to  use 
FOCUS  will  not  be  discussed  in  this  manual.  See  P/C 
FOCUS  Users  manual  release  2.0.  IBI  has  since  released 
FOCUS  version  3.0  with  a  new  manual. 


Portions  of  the  menu  system  were  written  in  the 


BASIC  language  under  the  IBM  Basic  Compiler  version 
1.0.  Other  software  included  COSORT  Version  4.0. 

4 . 5  FOCUS  PROGRAMS 

4.5.1  OVERVIEW 

The  FOCUS  programs  (or  procedures  as  the  FOCUS 
documentation  calls  them)  developed  for  the  ACDB  Study 
could  be  grouped  into  several  categories.  There  were 
the  load  programs,  the  reporting  programs,  the 
correction  programs,  the  dump  programs  and  other  utility 
programs . 

The  load  procedures  read  the  flat  files  written  by 
the  scanner  system  and  loaded  them  into  the  FOCUS  data 
base.  FOCUS  has  several  types  of  procedural  languages. 
The  load  procedures  were  written  as  Modify  Requests. 

The  reporting  procedures,  called  Table  Requests  by 
FOCUS,  print  or  display  on  the  computer  screen  various 
formatted  reports.  A  number  of  these  Table  Requests 
were  developed  as  standard  reports  and  sent  to  each  site 
as  part  of  the  menu  system.  They  could  be  called  up  and 
run  if  desired.  Other  Table  Requests  were  written  by 
site  personnel.  These  were  customized  reports  for  their 
particular  sites  and,  in  some  cases,  were  shared  among 
the  sites. 

Correction  procedures  are  a  combination  of  Table 
Requests  and  Modify  Procedures  used  to  correct  errors 
found  in  the  data  base.  FOCUS  has  a  package  called  SCAN 
that  can  be  used  to  correct  a  FOCUS  data  base;  it  is 
complex,  and  it  can  introduce  more  errors  or  destroy 
portions  of  the  data  base  when  used  by  inexperienced 
personnel . 

Dump  procedures  are  Table  Requests  that  send  the 
output  to  a  file  rather  than  a  printer.  These  files  are 
written  on  the  Iomega  cartridges  and  sent  to  Fort 
Detrick  for  inclusion  on  the  mainframe  data  base  also  in 
FOCUS . 

The  FOCUS  language  used  outside  of  Table  Requests 
and  Modify  Requests  to  control  administrative  tasks  is 
called  Dialogue  Manager.  Portions  of  the  menu  system 
were  written  in  Dialogue  Manager.  These  procedures, 
called  the  Load,  Dump,  Reporting  and  Correcting 
procedures,  returned  to  the  BASIC  menu  system  after 
execution. 
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4.5.2  PROFILE 


A  file  called  PROFILE. FEX  may  reside  in  a  directory 
in  which  FOCUS  is  invoked.  This  file  is  similar  to  the 
AUTOEXEC.BAT  file  in  DOS  in  that  it  executed 
automatically  each  time  FOCUS  is  called.  The  Basic 
programs  that  began  an  ACDB  session  had  the  capability 
to  write  a  PROFILE  file  for  specific  circumstances. 

Upon  exiting  from  the  system,  the  Basic  program  left  a 
generic  PROFILE  in  the  directory.  The  generic  form  of 
PROFILE. FEX  is  in  Appendix  D. 

4.6  MASTER  FILES 

The  structure  of  a  FOCUS  data  base  had  to  be 
described  in  a  master  file.  The  master  file  had  a  MAS 
extension  in  the  PC  and  contained  the  hierarchical 
structure  as  well  as  the  field  names  and  their 
attributes.  The  master  file  described  the  attributes  of 
a  data  file  with  the  same  name,  but  one  having  an 
extension  of  FOC. 

The  data  collected  from  all  the  encounter  forms  was 
stored  in  a  file  called  VISIT. FOC.  A  listing  of  the 
VISIT. MAS  file  is  provided  in  Section  4.6.1  to  show  the 
structure  of  the  file  and  all  field  names  with  their 
attributes.  The  first  line  shows  the  file  name.  The 
second  line,  and  all  other  lines  that  begin  with  SEGNAME 
describe  the  segment  names  and  their  relation  to  other 
segments.  The  second  line  has  no  parent  and  is, 
therefore,  the  root  segment,  A  pictorial  description  of 
the  segments  for  the  VISIT  file  is  shown  in  Section 
4. 6. 1.1.  The  first  line  in  each  box  is  the  segment  name 
and  the  other  line  is  the  first  field  name  in  that 
segment . 

The  lines  following  the  SEGNAME  lines  in  the  master 
file  description  give  the  field  names  and  their 
attributes  for  each  segment.  The  first  name  following 
'FIELD='  is  the  full  field  name  and  is  used  as  a  default 
report  heading  for  that  field.  The  second  name  is  an 
alias  which  primarily  is  an  abbreviated  name  used  in 
writing  FOCUS  procedures  (programs) .  The  next  item  in 
the  field  line  is  the  field  type.  Generally  the  types 
are  either  integer  or  alphabetical  and  are  indicated  in 
the  master  file  as  an  I  or  A  followed  by  the  size  of  the 
field.  Thus  the  third  line  has  a  field  name  called 
CLINIC,  an  alias  called  CL_UCA,  and  is  an  alphabetic 
field  having  a  length  of  four  characters.  The  only 
exception  to  field  type  is  in  the  fifth  line  for 
VISIT_DATE.  Here  the  size  is  followed  by  YMD  indicating 
the  date  is  stored  year,  followed  by  month,  followed  by 
day. 
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4.6.1  VISIT  MASTER  FILE 

FILE=VISIT , SUFFIX=FOC , $ 

SEGNAME=VISLOC, SEGTyPE=Sl , $ 

FIELD=CLINIC , CL_UCA , A4 , $ 

SEGNAME=VISDTE, PARENT=VISLOC, SEGTYPE=S1 , $ 
FIELD=VISIT_DATE , VDATE , I6YMD, $ 
SEGNAME=VISPROV , PARENT=VISDTE , SEGTYPE=S 1 , $ 
FIELD=PROV_ID, PROVl , A5 , $ 

SEGNAME=VISITOR, PARENT=VISPROV, SEGTYPE=S1 , $ 
FIELD=PATIENT_ID,PTID,A11,$ 

SEGNAME=LITHO, PARENT=VISITOR, SEGTYPE=S1 , $ 
FIELD=LITHO_CODE , LITHO , 18 , $ 

FIELD=FORM_NUM , FNUM , A2 , $ 

FIELD=VISIT_CNT, VCNT, II, $ 

FIELD=PROVl_TIME , TIMEl , 13 , $ 
FIELD=PROVIDER_2 , PROV2 , A5 , $ 
FIELD=PROV2_TIME, TIME2 , 13 , $ 
FIELD=PROV2_RESON , PROV2RES , A1 , $ 
FIELD=APPT_STATUS , APPSTAT , A1 , $ 
FIELD=PLACE_OF_VIS , PLACE , A1 , $ 
FIELD=INP_REFERAL, REFERAL, A4 , $ 
FIELD=JOB_RELATED , JOBREL, A1 , $ 
FIELD=MIL_DUTY , DUTY , A1 , $ 

FIELD=MIL_QTR , QTR , A1 , $ 

FIELD=MIL_PROF , PROF , A1 , $ 

FIELD=NOT_AVAIL, NAVAIL, A1 , $ 
FIELD=ADMITTED, ADMIT,A1, $ 

FIELD=INFIELD , ILLN , A1 , $ 

FIELD=INJURIES , INJ , A1 , $ 

FIELD=PURP_VIS , PURP , A1 , $ 

FIELD=RO_F_UP , RULE , A1 , $ 

FIELD=DIAGl_CODE , DXICODE , A5 , $ 
SEGNAME=V_PROC, PARENT=LITHO, SEGTYPE=S1 , $ 
FIELD=PROC_CODE , PCODE , A5 , $ 

FIELD=PROV_CD , PRCODE , A1 , $ 

SEGNAME=V_SPCC, PARENT=LITHO, SEGTYPE=S1 , $ 
FIELD=SP_PRE_CODE , SPCC , A1 , $ 
SEGNAME=V_OTHER , PARENT=LITHO , SEGTYPE=S1 , $ 
FIELD=OTHER_CODE , OTHER, A5 , $ 
SEGNAME=V_GROUP, PARENT=LITHO, SEGTYPE=S1 , $ 
FIELD=UNIT_ID , UIC , A6 , $ 

FIELD=TIME_PR1 , TIMPRl , 13 , $ 

FIELD=TIME_PR2 , TIMPR2 , 13 , $ 

FIELD=TIME_TR1 , TIMTRl , 13 , $ 

FIELD=TIME_TR2 , TIMTR2 , 13 , $ 
FIELD=NO_ACT_DUTY , MACT , 13 , $ 
FIELD=NO_OTH_DUTY , OACT , 13 , $ 
FIELD=NO_RET_MIL,RMIL, 13 , $ 
FIFLD=NO_DEPEND, DEPD, 13 , $ 

Fli.LD=NO_CIVIL,  CIVIL,  13  ,  $ 
FIELD=CONT_SHEET,CSHEET,Al, $ 
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SEGNAME=V_SPEC , PARENT=LITHO , SEGTYPE=S 1 , $ 
FIELD=SPEC_PROG , SPROG , A1 , $ 
SEGNAME=V_DIAG2 , PARENT=LITHO, SEGTYPE=S1 , $ 
FIELD=DIAG2_CODE , DX2CODE , A5 , $ 
SEGNAME=V_PS Y , PARENT=LITHO , SEGTYPE=S 1 , $ 
FIELD=ASSESMNT , ASSESMNT , A1 , $ 
SEGNAME=V_DISPOS , PARENT=LITHO , SEGTYPE=S 1 , $ 
FIELD=DISPOS , DISP , A2 , $ 

SEGNAME=V_GRSSN , PARENT=LITHO , SEGTYPE=S 1 , $ 
FIELD=GR_PAT_ID, GPATID, All , $ 

END 

DBA=LUGNUT,$ 

USER=NUTMEG , ACCESS=RW , $ 


4. 6. 1.1  PICTURE  OF  VISIT  FILE 


PICTURE  DESCRIPTION  OF  FOCUS  DATA  BASE 


4.6.2  PATIENT  MASTER  FILE 

FILE=PATIENT , SUFFIX=FOC 

SEGNAME=PTSEG, SEGTYPE=S1 

FIELD=PATIENT_ID, PTID, All , FIELDTYPE=I , $ 
FIELD=PT_DOB, PTDOB, I6YMD, $ 
FIELD=PT_CATEGORY , CATEG, A3 , $ 
FIELD=PT_LITHO , PTLITHO, AS , $ 
FIELD=PT_REGDATE , REGDATE , I 6YMD , $ 
FIELD=PT_GENDER , SEX , A1 , $ 

FIELD=PT_RACE , RACE , A1 , $ 

FIELD=PT_PREFIX, PREFIX, A2 , $ 
FIELD=PT_PAY_GRADE , PAYGRADE , A2 , $ 
FIELD=PT_JOB_CODE , JOBCODE , A4 , $ 
FIELD=PT_LOCATION , PTLOC , A6 , $ 
FIELD=PT_TRN_TDY , TRAINEE , A1 , $ 
FIELD=PT_VAELIG , VA , Al , $ 

FIELD=PT_HCI , HCI , Al , $ 

FIELD=PT_ZIP_CODE, ZIP, A5, $ 
FIELD=PT_DUAL_SSN , PTDUALSSN , A9 , $ 
FIELD=PT_FOREIGN , PTFORGN, A3 , $ 

END 

DBA=LUGNUT,$ 

USER=NUTMEG,  ACCESS=RW,  $ 


4.6.3  PROVIDER  MASTER  FILE 

FILE=PROVIDER, SUFFIX=FOC 

SEGNAME=PROVIDER, SEGTYPE=S1 

FIELD=PROV_ID, PROVID, A5, FIELDTYPE=I , $ 
FIELD=PROV_DATE , PROVDATE , I6YMD , $ 
FIELD=PROV_LST_NME , PRLNME , A16 , $ 
FIELD=PROV_FST_NME , PRFNME , A13 , $ 
FIELD=PROV_INIT , PRINIT, Al , $ 
FIELD=PROV_STAT , PRSTAT , Al , $ 
FIELD=PROV_CATEG, PRCATEG, A2 , $ 
FIELD=PROV_PRPOS , PRPOS , A2 , $ 
FIELD=PROV_PAYGR, PRPAYGR, A2 , $ 
FIELD=PROV_JOBCODE , PRJCODE , A7 , $ 
FIELD=PROV_SSN , PRSSN , A9 , $ 
FIELD=PROV_LITHO, PRLTH, AS , $ 

END 

DBA=LUGNUT,$ 

USER=NUTMEG,  ACCESS=RW,  $ 
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FILENAME=CLINIC, SUFFIX=FOC 


SEGNAME=CLINIC , SEGTyPE=Sl 
FIELDNAME=sCLINIC,  ALIAS=CLUCA, 

F0RMAT=A4 , FIELDTYPE=I , $ 

FIELDNAME=CL_TITLE,  ALIAS=302CLTITLE,  FORMAT=A20 
FIELDNAME=CL_302CODE,  ALIAS=302CLCODE,  F0RMAT=A2 
FIELDNAME=CL_3  02LINE , ALIAS=3  02CLLINE ,  FORMAT=I 3 

END 

DBA=LUGNUT,$ 

USER=NUTMEG,  ACCESS=RW,  $ 


i 


t 


4.6.5  DIAGNOSIS  MASTER  FILE 

FILENAME=DIAGNOS , SUFFIX=FOC 
SEGNAME=DIAGNOS , SEGTyPE=Sl 

FIELDNAME=DIAG_CODE, ALIAS=DGNCD, FORMAT=A5 , FIELDTyPE=I , $ 
FIELDNAME=DIAG_DESCR,ALIASs=DGNDSC,  FORMAT=A50  ,$ 

END 

DBA=LUGNUT , $ 

USER=NUTMEG,  ACCESS=RW,  $ 


4.6.6  PROCEDURE  MASTER  FILE 


FILENAME=PROCEDUR, SUFFIX=FOC 
SEGNAME=PROCEDUR, SEGTyPE=Sl 

FIELDNAME=PROC_CODE ,  ALIAS=PRCCD, FORMAT=A5 , FIELDTYPE=I , $ 
FIELDNAME=PROC_DESCR,ALIAS=PRCDSC,  FORMAT=A67  ,$ 

END 

DBA=LUGNUT,$ 

USER=NUTMEG,  ACCESS=RW,  $ 


4.6.7  OTHER  CODE  MASTER  FILE 


FILENAME=OTHER, SUFFIX=FOC 
SEGNAME=OTHERCOD, SEGTyPE=Sl 

FIELDNAME=OTHER_CODE ,  ALIAS=OTHC , FORMAT=A5 , FIELDTYPE=I , $ 
FIELDNAME=OTHER_DESCR , ALIAS=OTHDSC , FORMAT=A67  , $ 

END 

DBA=LUGNUT,$ 

USER=NUTMEG,  ACCESS=RW,  $ 
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4 . 7  FIELD  DESCRIPTIONS 

4.7.1  VISIT  FIELD  DESCRIPTIONS 

The  following  list  describes  all  the  fields  in  the 
VISIT  file  providing  additional  information  such  as  a 
description  of  acceptable  input  values,  ranges,  and 
names  as  given  on  the  encounter  form: 

FIELD  ALIAS  DESCRIPTION _ 


CLINIC 

CL  UCA 

Clinic  code 

VISIT  DATE 

VISIT  DAT 

Visit  date 

PROV  ID 

PROVl 

Provider  l  ID 

PATIENT  ID 

PTID 

SSN  and  FMP 

LITHO  CODE 

LITHO 

Form  serial  number 

FORM  NUM 

FNUM 

Form  type 

VISIT  CNT 

VCNT 

Visit  count  (0-9) 

PR0V1_TIME 

TIMEl 

Provider  1  time  (minutes) 

PROVIDER  2 

PR0V2 

Provider  2  ID 

PR0V2  TIME 

TIME2 

Provider  2  time  (minutes) 

PR0V2  RESON 

PROV2  RES 

Reason  for  Prov  2 

1  Teaching 

2  Consultation 

3  Procedure 

4  Other  1 

5  Other  2 

6  Other  3 

7  Cor-therapist 

APPT_STATUS  APPSTAT  Appointment  Status 

1  Scheduled 

(Also  ER  sched  foll-up) 

2  Unscheduled 

3  Emergency 

4  Walk  in 

5  Sick  call 

PLACE_OF_VIS  PLACE  Place  of  visit 

1  Clinic 

2  Ward 

3  Telephone 

4  Home 

5  Other  1 

6  Other  2 

7  Other  3 

8  ER  Seen  last  48  hr 

INP_REFERAL  REFERAL  Referral  Clinic  code 

JOB_RELATED  JOBREL  Job  related  (Y/N) 

OCC  HEALTH 
N  Not  job  related 

1  Fatal  case 

2  Lost  time  case 

3  No  lost  time  case 
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MIL_DUTY 

M1L_QTR 

MIL_PROF 

NOT_AVAIL 

ADMITTED 

INFIELD 

INJURIES 


PURP  VIS 


RO  F  UP 


DUTY 


QTR 


PROF 


NAVAIL 

ADMIT 

ILLN 


INJ 


PURP 


RULE 


Military  Duty 

1  Duty 

2  Limited  Duty 

3  TMC 

4  Self  Care  Protocol 
Military  Quarters 

1  24  hours 

2  48  hours 

3  72  hours 
Military  Profile 

1  1-3  days 

2  4-7  days 

3  8-14  days 

4  >14  days 

No  Data  in  this  field 

See  SPEC  PRE  CLINIC 
Admitted  (Y/N) 

For  BAS:.  Field  (Y/N) 

For  Occ  He:  Illness 
N  New 
R  Revisit 


Injuries 

BAS/TMC 

1  PT 

2  Unit  sport 

3  MOS/duty 

4  Field  duty 

5  Motor  veh  accident 

6  Airborne  Ex. 

OCC  HEALTH 

N  New 
R  Revisit 

Purpose  of  visit  (Occ  He) 

A  preplacement/preass 
B  Periodic 
C  Termination 
D  Baseline  hlth  assess 
E  Pregnancy  surv 
F  Chronic  dis  surv 
G  Voluntary  hlth  scr 
H  Follow-up 
I  Fitness  for  duty 
J  Disab  retirement 
K  Illness  abs  mon 
L  Med  eval  (claimant) 

M  Med  eval  of  empl 
Rule  out/Follow-up 

1  Rule  out 

2  Follow-up 
Primary  Dx  code 
Procedure  code 


DIAG1_C0DE 
PROC  CODE 


DXICODE 

PCODE 


PROV_CD 

PRCODE 

Provider  giving  proc 

1  Prov  1 

2  Prov  2 

3  Out 

SP_PRE_CODE 

Spec 

Specific  preassigned  codes 
Not  Available 

M  Medical  records 

L  Lab  results 

X  Xrays 

OTHER  CODE 

OTHER 

Other  codes  (Incl  M  codes) 

UNIT_ID 

UIC 

Unit  ID  code 

Time  spent  with  group  coded 
as  provl  and  prov2  time 

TIME  PRl 

TIMPRl 

Time  spent  prep  prov  1 

TIME  PR2 

TIMPR2 

Time  spent  prep  prov  2 

TIME  TRl 

TIMTRl 

Time  spent  travel  prov  1 

TIME  TR2 

TIMTR2 

Time  spent  travel  prov  2 

NO  ACT  DUTY 

MACT 

Number  Army  Active  duty 

NO  OTH  DUTY, 

OACT 

Number  Other  Active  duty 

NO  RET  MIL 

RMIL 

Number  Retired  Military 

NO  DEPEND 

DEPD 

Number  dependents 

NO  CIVIL 

CIVIL 

Number  civilians 

CONT  SHEET 

eSHEET 

Continuation  sheet 

SPEC_PROG 

SPROG 

Special  programs 

1  FAP 

2  ADAPCP 

3  PRP 

4  Adoption 

5  Other  1 

6  Other  2 

7  Other  3 

DIAG2  CODE 

DX2CODE 

Secondary  Dx  code 

ASSESMNT 

ASSESMNT 

Psychometric  Assessment 

1  Personality 

2  Intellectual 

3  Neuropsychological 

4  Other 

DISPOS 

DISP 

Dispositions  (1-13) 

GR_PAT_ID 

GPATID 

Group  patient  ssn  &  fmp 
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4.7.2  PATIENT  FIELD  DESCRIPTIONS 


1> 


PATIENT  ID 


PT_DOB 
PT  CATEGORY 


ALIAS  DESCRIPTION _ 

PTID  Social  Security  number  followed 
by  FMP  (11  digits) 

PTDOB  Date  of  Birth  (yymmdd) 

CATEG  Category 

AlO  Army  Active  Duty 

A21  Army  Reserve  Tng 

A23  Army  Reserve  IDT/AT/ADT 

A24  Army  NG  Tng 

A26  Army  NG  IDT/AT/ADT 

A30  Army  Retired 

A50  Army  Depn  Active  Duty 

A60  Army  Depn  Retired/dec. 

A70  Army  USMA  Cadet 

A80  Army  ROTC  Cadet/Applic. 

CIO  CG  Active  Duty 

C20  CG  Reserve/NG 

C30  CG  Retired 

C50  CG  Depn  Active  Duty 

C60  CG  Depn  Retired/dec. 

C70  CG  Academy  Cadet 

FIO  AF  Active  Duty 

F20  AF  Reserve/NG 

F30  AF  Retired 

F50  AF  Depn  Active  Duty 

F60  AF  Depn  Retired/dec. 

F70  AF  Academy  Cadet 
F80  AF  ROTC  Cadet/Applic. 

H26  Civilian 
NIO  Navy  Active  Duty 
N20  Navy  Reserve/NG 
N30  Navy  Retired 
N50  Navy  Depn  Active  Duty 
N60  Navy  Depn  Retired/dec. 
N70  Navy  Academy  Cadet 
N80  Navy  ROTC  Cadet/Applic. 
MIO  Marine  Active  Duty 
M20  Marine  Reserve/NG 
M30  Marine  Retired 
M50  Marine  Depn  Active  Duty 
M60  Marine  Depn  Retired/dec. 
PIO  USPHS  Active  Duty 
P20  USPHS  Reserve 
P30  USPHS  Retired 
P50  USPHS  Depn  Active  Duty 
P60  USPHS  Depn  Retired/dec. 
OTH 
OlO 
020 
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333 


FIELD 


ALIAS 


I 


LITHO 

REGDATE 

GENDER 


DESCRIPTION 


030 

050 

060 

HIO 

H20 

H30 

H38 

H40 

H50 

JIO 

J20 

J30 

KIO 

K20 

K30 

K40 

K42 

K43 

K50 

K51 

K60 

K70 

QIO 

RIO 

SIO 

S20 

523 

524 
S30 
S32 
S40 
S50 
S60 
XIO 
X20 
X30 
X40 
X45 
X52 
X60 
X70 


PTLITHO  Form  serial  number 
REGDATE  Registration  date 
SEX  Sex  (M,F) 


(8  digits) 
( yymmdd ) 
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lELD  ALIAS  DESCRIPTION _ 

PT_RACE  RACE  Race 

1  Am.  Indian/Alaskan  Native 

2  Asian/Pacific  Islander 

3  Black/Not  Hispanic  Origin 

4  Black/Hispanic  Origin 

5  White/Not  Hispanic  Origin 

6  White/Hispanic  Origin 

7  Unknown 

PTPREFIX  prefix  Position 

E  Enlisted 
O  Officer 
W  Warrant  Officer 
GS  Civilian 
GM  Civilian 
WG  Civilian 
WL  Civilian 
WS  Civilian 
NF  NAF 
CT  Contract 
OT  Other 

PT_PAY_GRADE  PAYGRADE  Pay  grade  (01-16) 

PT_JOB_CODE  JOBCODE  Duty  MOS/SSI  or  Civilian  Occ. 

Series 

PT_LOCATION  PTLOC  Unit  ID  Code  or  Building  No. 

PT_TRN_TDY  TRAINEE  Trainee  or  on  TDY  (Y,N) 

PT_VAELIG  VA  Eligible  for  VA  benefits  (Y,N) 

PT_HCI  HCI  Health  Care  Insurance  (Y,N) 

PT_ZIP_CODE  ZIP  Zip  code 

PT_DUAL_SSN  PTDUALSSN  Civilian  SSN 

PT_FOREIGN  PTFORGN  Foreign  National  Country  Code 


1 


4.7.3  PROVIDER  FIELD  DESCRIPTIONS 


FIELD  ALIAS  DESCRIPTION _ 

PROV_ID  PROVID  First  initial  of  last  name  plus 

last  four  digits  of  SSN 
PROV_DATE  PROVDATE  Registration  date 

PROV_LST_NME  PRLNME  Last  name 

PROV_FST_NME  PRFNME  First  name 

PROV_INIT  PRINIT  Middle  initial 

PROV_STAT  PRSTAT  Status 

1  Permanent  staff  at  MTF 

2  All  others 
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L 


LD 


PROV  CATEG 


S 


PRCATEG 


PROV  PRPOS 


PRPOS 


PROV  PAYGR  PRPAYGR 


PROV  JOBCODE  PRJCODE 


PROV_SSN 
PROV  LITHO 


PRSSN 

PRLTH 


SCRIPTION 


Category  (2  digits) 

First  digit  -  Branch 

1  Army 

2  Air  Force 

3  Navy 

4  Marines 

5  Coast  Guard 

6  PHS 

7  Other 

Second  digit  -  Category 

1  Officer 

2  Warrant  Officer 

3  Enlisted 

4  Civilian  (DAC) 

5  Contract 

6  Consultant 

7  Other 
Position 

1  CDR/DCCS 

2  Chief  Dept. /S VC. 

3  Fellow 

4  Resident 

5  Intern 

6  Nurse  Pract. 

7  Nurse  Clin. 

8  NCOIC 

9  Student 

10  All  Others 
Pay  grade  ( 2  char . ) 

First  Char.  -  Prefix 
E  Enlisted 
O  Officer 
W  Warrant  Officer 
Second  Char.  -  pay  grade  (1-9) 
Job  code  (7  char) 

Army 


Char. 

1-3 

-  MOS 

Char. 

4 

-  SSI 

Char. 

5,6 

-  ASI 

Char. 

7 

-  blank 

Air  Force 

Char. 

1-7 

-  AFSC 

Navy 

Char. 

1-6 

-  NOBC/NEC 

Char. 

7 

-  blank 

Other  Branches  -  7  blanks 
Provider  SSN 

Form  serial  number  (8  digits) 
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4.7.4  CLINIC  FIELD  DESCRIPTIONS 


FIELD 

ALIAS 

DESCRIPTION 

CLINIC  CLUCA 

CL  TITLE  302CLTITLE 

CL  302CODE 

CL  302LINE 

UCA  Code  for  Clinic 

Clinic  description 

Not  used 

Not  used 

4.7.5  DIAGNOSIS 

FIELD  DESCRIPTIONS 

FIELD 

ALIAS 

DESCRIPTION 

DIAG  CODE 
DIAG_DESCR 

DGNCD 

DGNDSC 

Diagnosis  code 

Diagnosis  description 

4.7.6  PROCEDURE 

FIELD  DESCRIPTIONS 

FIELD 

ALIAS 

DESCRIPTION 

PROC  CODE 
PROC  DESCR 

PRCCD 

PRCDSC 

Procedure  code 

Procedure  description 

4.7.7  OTHER  FIELD  DESCRIPTIONS 

FIELD 

ALIAS 

DESCRIPTION 

OTHER  CODE 
OTHER  DESCR 

OTHC 

OTHDSC 

Other  code 

Other  code  description 

4 . 8  LOADING 

Data  was  loaded  into  the  FOCUS  data  base  from  ASCII 
files  produced  by  the  scanner  system  or  manually 
prepared.  Listings  of  the  Load  procedures  are  in 
Appendix  D.  They  are:  LOADCLIN.FEX,  LOADDIAG. FEX, 

LOADPROC.FEX,  LOADOTH.FEX,  RXXF200.FEX,  RXXF300.FEX,  and 
RXXF400.FEX.  The  first  four  programs  loaded 
descriptions  for  the  clinic,  diagnosis,  procedure,  and 
other  codes.  The  last  three  programs  loaded  the 
patient,  provider,  and  visit  data  respectively.  One 
other  load  program,  DEERS. FEX,  was  written  later  in  the 
study  to  load  the  DEERS  data. 

4 . 9  REPORTING 

Report  programs  were  written  early  in  the  study  to 
provide  the  sites  with  an  immediate  use  for  the  data.  j 
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since  the  precise  requirements  of  each  site  were  not 
known,  general  reporting  programs  were  designed.  Many 
sites  used  these  programs,  but  as  the  site  operators 
became  experienced  in  FOCUS,  customized  programs  were 
written  and  used. 


There  were  12  report  programs  initially  provided, 
however,  two  were  never  completed.  The  programs  are 


CLINICl.FEX 

CLINIC2.FEX 

CLINIC3 . FEX 

CLINIC4.FEX 

MILTl.FEX 

MILT2.FEX 


MILT3.FEX 
PROVl . FEX 
PROV2 . FEX 
PROV3 . FEX 
PR0V4 . FEX 
PR0V5 . FEX 


Listings  of  the  above  programs  are  in  Appendix  D. 


4.10  CORRECTING 


It  became  obvious  early  in  the  study  that  errors  in 
the  data  base  caused  various  reporting  anomalies.  The 
ability  to  correct  the  errors  through  FOCUS  was 
limited.  An  available  SCAN  utility  could  cause  the  data 
base  to  become  corrupt  beyond  repair.  It  could  also 
cause  other  problems  such  as  duplicate  keys.  Only  an 
experienced  programmer  should  attempt  to  use  SCAN  and 
then  only  under  emergency  conditions. 

Another  problem  lay  in  the  correction  of  key 
fields.  FOCUS  did  not  allow  these  fields  to  be 
corrected  through  the  modify  routines  which  could  be 
used  for  correcting  data.  Thus  an  attempt  was  made  to 
write  some  programs  that  could  correct  the  data  to 
include  key  fields  and  that  would  be  safe  to  use.  Three 
programs  were  written  to  correct  the  Clinic  field. 
Provider  field  and  the  Patient  ID  field.  The  programs 
were  RXXFCCL.FEX,  RXXFCPR.FEX  and  RXXFCPA.FEX. 

Supporting  programs  for  the  above  are  RXXCORL.FEX, 
RXXCCLD.FEX,  RXXCPAD.FEX,  and  RXXCPRD.  Listings  of 
these  programs  are  in  Appendix  D. 

The  correction  programs  provided  a  menu  system 
through  which  errors  in  certain  fields  could  be 
changed.  The  affected  segments  were  then  correctly 
written  out  to  a  temporary  file.  The  temporary  file  was 
then  read  back  into  the  data  base.  Finally,  the 
incorrect  records  were  deleted.  Although  the  method 
worked,  it  was  time  consuming,  particularly  at  end  of 
month  processing  when  the  data  base  was  large. 

Typically  a  single  correction  (which  may  affect  one  or 
hundreds  of  segments)  took  over  an  hour. 


# 
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4.11  DUMPING 


Each  month  the  data  collected  at  the  sites  had  to 
be  sent  to  Ft.  Detrick  for  inclusion  in  the  total  data 
base.  Since  the  data  could  not  be  uploaded  in  the  FOCUS 
structure,  an  ASCII  file  was  created.  As  the  data  was 
medically  sensitive,  identifying  fields  were  encrypted 
during  the  dump.  Thus  the  data  was  protected  the 
instant  it  left  the  site.  Dump  programs  for  the  visit, 
patient,  and  provider  files  are  in  Appendix  D.  They  are 
RXXFDVI.FEX,  RXXFDPA.FEX,  and  RXXFDPR.FEX  respectively. 
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5.0  SPECIAL  TOPICS 

Some  topics  span  more  than  one  system  and  are 
therefore  inconvenient  to  classify.  A  special  topic 
section  is  devoted  to  these  cases.  One  such  topic  is 
Patient  registration,  the  problems  associated  with  it, 
and  attempts  to  bolster  registrations  with  the  SIDPERS 
and  the  DEERS  data. 

5.1  PATIENT  REGISTRATION 

A  form  for  patient  registration  was  designed,  and 
an  attempt  to  register  all  out-patients  was  made. 
However,  after  a  few  months  patient  registrations  fell 
behind  at  all  sites,  and  the  Patient  file  represented 
about  a  third  of  the  patients  being  seen.  In  an  attempt 
to  bolster  the  patient  registrations,  the  study  team 
drew  upon  data  from  two  outside  sources  -  SIDPERS  and 
DEERS . 

The  data  from  SIDPERS  and  DEERS  were  sent  directly 
to  Ft  Detrick.  At  Ft.  Detrick  the  data  had  to  be 
converted  to  the  format  design  for  the  ACDB  Study.  Then 
a  data  set  was  sent  to  the  site  for  inclusion  in  their 
Patient  file,  and  a  copy  was  added  to  the  cumulative 
Patient  file  on  the  mainframe  computer. 

Addition  of  the  SIDPERS  and  DEERS  data  brought  the 
percentage  of  registrations  to  over  65%  in  some  cases; 
however,  not  all  fields  on  the  registration  forms  were 
available  in  the  outside  data.  Another  difficulty  was 
that  the  Patient  file  began  to  grow  beyond  the  storage 
capabilities  of  the  ACDB  computer  systems.  The  problem 
was  that  many  individuals  that  never  made  a  hospital 
visit  were  being  added  to  the  data  base  each  month. 
Although  this  problem  was  discussed,  no  good  solution 
was  found  for  deleting  these  unwanted  individuals  from 
the  data  base.  This  is  an  area  warranting  further 
review,  research  and  testing. 

5.2  SIDPERS 

SIDPERS  data  was  sent  by  tape  monthly  from  Ft. 

Polk,  Ft.  Jackson,  Ft.  Campbell  and  Ft.  Bragg  since 
these  sites  had  a  large  turnover  in  trainees.  The  data 
represented  new  personnel  arriving  each  month.  More 
information  was  collected  on  the  registration  forms  than 
was  available  from  SIDPERS.  Also,  some  of  the  data  was 
in  a  different  format.  The  data  from  SIDPERS  had  to  be 
transformed  before  being  added  to  the  patient  data  base. 
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5.2.1  SIDPERS  TAPE  FORMAT 


The  SIDPERS  tapes  were  requested  to  be  sent 
unlabeled  and  in  EBCDIC  (IBM  compatible) .  Each  record 
was  30  characters  in  length  and  contained  the  following 
fields: 


Column 

Descriotion 

1-9 

Social  Security  Number 

10 

MPC 

11 

Grade 

12 

Sex 

13-17 

Duty  MOS 

18-22 

UPC 

18-22 

DOB  (yymmdd) 

29 

Race 

30 

Blank 

5.2.2  SIDPERS  CONVERSION 

The  data  from  the  SIDPERS  tapes  had  to  be  converted 
to  conform  to  the  ACDB.  Conversion  was  made  using  a 
BASIC  program  called  CONVERT.EXE  on  the  PC  for  files 
being  sent  back  to  the  sites.  A  mainframe  program, 
SIDCONV,  written  in  SAS  performed  the  conversion  for  the 
mainframe  Patient  file.  SIDCONV  also  added  the  site  ID 
to  each  record  and  encrypted  the  Social  Security  Number. 

The  conversions  performed  are  as  follows: 


GRADE 


Enlisted  (MPC  =  E) 

GRADE  CONVERT  TO 
M  04 

N  05 

O  06 

P  07 

R  08 

X  01 

Y  02 

1-9  01-09 

Officer  (MPC  =  O) 

GRADE  CONVERT  TO 
A  08 

B  06 

C  05 

D  04 

E  03 
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RACE  CONVERT  TO 


blank  7 

C  5 

M  2 

N  4 

R  1 

X  7 


JOBCODE 

If  MFC  =  E  then  JOBCODE  is  0  plus  left  two 
positions  of  Duty  MOS  plus  a  W. 

If  MFC  =  O  then  JOBCODE  is  0  plus  left  two 
positions  of  Duty  MOS  plus  a  W. 

If  MFC  =  W  then  JOBCODE  is  left  two  positions  of 
Duty  MOS  plus  a  blank  plus  a  W. 

OTHER  ADDED  FIELDS 


FROG ID  =  200  Frogram  ID 

FMF  =20  Family  member  prefix 

CAT  =  AlO  Category 

ZIP  =  28307  Zip  Code  for  Ft.  Bragg 

=  42223  Zip  Code  for  Ft.  Campbell 

=  29207  Zip  Code  for  Ft.  Jackson 

=  71459  Zip  code  for  Ft.  Polk 

SEQ  =  Sequence  number  used  as  the  eight  digit 
Litho  code.  To  identify  SIDPERS  records 
a  letter  (B  -  Bragg,  C  -  Campbell, 

J  -  Jackson,  P  -  Polk)  was  placed  in  the 
units  position  of  the  number. 
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5.2.3  SIDPERS  OUTPUT  RECORD 


The  output  record  from  the  CONVERT  program  is 


COLUMN 

FIELD 

DESCRIPTION 

1-3 

PROGID 

Program  ID  (200) 

4-12 

SSN 

Social  Security  Number 

13-14 

FMP 

Family  Member  Prefix 

15-20 

DOB 

Date  of  Birth  (yymmdd) 

21-23 

CAT 

Category  (AlO) 

24-31 

SEQN 

Litho  followed  by  letter 

32-37 

DAT 

Registration  date  (yymmdd) 

38 

SEX 

Sex 

39 

RACE 

Race 

40 

MPC 

Military  pay  code  prefix 

41 

blank 

42-43 

GRADE 

Pay  grade 

44-46 

JC 

job  code 

47 

W 

Last  character  of  Job  code 

48-53 

UPC 

Location 

54-56 

blank 

57-61 

ZIP 

Zip  code 

62-73 

blank 

This  output  record  contains  blank  fields  which  make  the 
record  format  consistent  with  the  output  records  created 
by  scanning  the  patient  registration  forms.  Thus  the 
same  program  can  be  used  when  loading  patient  data  into 
the  FOCUS  data  base  regardless  of  the  raw  data  source, 
that  is,  from  ACDB  forms,  SIDPERS  or  DEERS. 

5 . 3  DEERS 


The  DEERS  data  was  sent  in  an  attempt  to  capture 
retired  personnel  and  dependents  as  well  as  to  update 
movement  in  active  duty  personnel.  DEERS  tapes  were 
created  by  selecting  registered  DEERS  individuals  within 
a  fifty  mile  radius  of  each  site.  The  fifty  mile  radius 
was  determined  by  the  zip  code  in  the  address  of  the 
individual.  The  DEERS  data  was  sent  quarterly  from 
Department  of  Defense,  Manpower  Data  Center,  Monterey, 

CA  93940. 

The  large  number  of  records  on  the  DEERS  tapes, 
particularly  for  BAMC,  caused  the  patient  registration 
file  to  exceed  available  capacity.  As  mentioned  before, 
various  ways  were  discussed  to  resolve  the  patient 
registration  problem,  but  no  solutions  were  found.  The 
DEERS  tapes  contained  many  people  that  never  made  a 
hospital  visit,  so  while  the  tapes  increased  the 
percentage  of  patients  registered,  they  created  a  great 
deal  of  unused  information  to  be  stored. 
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Two  possible  remedies  are  to  compare  Social 
Security  numbers  from  DEERS  data  with  actual  patients 
and  accept  only  matches  or  to  use  a  smaller  geographical 
area  for  selection  of  DEERS  records.  In  the  first 
instance,  once  every  quarter  the  data  would  be  brought 
up-to-date  but  during  the  quarter  registration  data 
would  lag  a  bit.  The  primary  disadvantage  of  this 
method  is  the  amount  of  computing  needed;  it  was  for 
this  reason  it  was  never  tried.  The  sites  personnel  had 
too  much  to  do  during  most  of  the  study  to  attempt  this 
procedure.  This  method  would  have  required  that  the 
tapes  be  sent  to  Ft.  Detrick  to  be  read,  downloaded  to 
Bernoulli  cartridges,  and  then  returned  to  the  sites. 

The  sequential  DEERS  data  on  the  cartridges  would  have 
had  to  be  loaded  into  the  patient  Focus  file.  Programs 
would  have  had  to  be  written  to  perform  the  matching  and 
selecting  these  matches  for  inclusion  in  the  patient 
file. 


An  analysis  could  be  made  as  to  how  much  patient 
registration  increased  based  on  the  number  of  miles  from 
the  site.  A  50-mile  radius  was  arbitrarily  selected  but 
perhaps  a  40-mile  radius  would  be  adequate.  A  tape  of 
zip  codes  with  mileage  from  the  sites  was  sent  to  Ft. 
Detrick  for  analysis  near  the  end  of  the  data  collection 
portion  of  the  study.  As  a  result  no  analyis  of  zip 
codes  was  done. 


5.3.1  DEERS  TAPE  FORMAT 


The  format  of  the  DEERS  tape  is  given  below.  The 
DEERS  data  contained  more  fields  than  were  needed  for 
the  ACDB  Study.  Therefore,  only  those  fields  used  are 
provided.  While  the  DEERS  tapes  were  essentially  a  copy 
of  existing  DEERS  tapes,  an  additional  field,  the  UIC 
for  active  Army  personnel,  was  inserted  over  the  top  of 
an  address  field. 


POSITION  SIZE 


1-9  9 

11-12  2 

40-45  6 

107-111  5 

116  1 

117-118  2 

119  1 

121-126  7 

127  1 


DESCRIPTION _ 

Social  Security  Number 

Dependent  Sequence  Number 

UIC  for  Army  Active  Duty 

Zip  code 

Branch 

Paygrade 

Sex 

Date  of  Birth 
Sponsor  Status 


5.3.2  DEERS  FIELD  DEFINITIONS 

DEPENDENT  SEQUENCE 
01-19  Child 
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20 

Sponsor 

30-39 

Spouse 

40-44 

Mother 

45-49 

Father 

50-54 

Mother-in-law 

55-59 

Father- in-law 

60-69 

Other 

ONSOR 

STATUS 

A  Active  Duty 
B  Recalled  Active  Duty 
C  civilian 
D  DAV 
E  MEPCOM 
J  Academy  Student 
R  Retired 

S  Serv.  Sec.  Designee 

V  Reservist  on  Active  Duty 

Z  Unknown 

BRANCH 
A  Army 

E  Public  Health 
F  Air  Force 
I  NOAA 
M  Marine 
N  Navy 
P  Coast  Guard 
X  Other 
Z  Unknown 

5.3.3  DEERS  CONVERSION 

As  with  the  SIDPERS  tapes,  a  number  of  fields 
require  conversion  to  conform  to  the  fields  defined  by 
the  Patient  Registration  Forms.  A  SAS  program  called 
DEERS  in  the  partitioned  data  set  DXB . ACDB . CNTL  is  used 
to  convert  the  DEERS  tapes. 

The  conversions  performed  are  as  follows: 

PAYGRADE 

GRADE  CONVERT  TO 
01-09  E01-E09 

10-14  W01-W04 

21-30  001-010 

44-49  E04-E09 

DATE  OF  BIRTH 


DOB  CONVERT  TO 
yyymmdd  yymmdd 
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UIC  CODES 

The  sponsor  status  was  used  to  determine  whether  or 
not  an  individual  was  active  duty.  If  the 
individual  was  active  duty  then  the  UIC  was  taken 
from  the  record.  Otherwise,  blanks  were  used  for 
the  UIC.  The  following  are  sponsor  codes  for 
active  duty: 

CODE 
A 
B 
E 
J 
N 
V 
Z 


DEFINITION _ 

Active  Duty 
Recalled  Active  Duty 
MEPCOM 

Academy  Student 
National  Guard  Active  Duty 
Reservist  on  Active  Duty 
Unknown 


CATEGORY 

Category  was  determined  by  Sponsor  Status,  Branch 
and  dependent  sequence.  Conversion  is  shown  in  the 
following  table: 

FOR  DEPENDENT  STATUS  =20 


SPONSOR  STATUS 


BRANCH 

A 

B 

J 

N 

R 

V 

A 

AlO 

AlO 

A70 

A26 

A30 

A23 

E 

PIO 

PIO 

X70 

X70 

P30 

P20 

F 

FIO 

FIO 

F70 

F20 

F30 

F20 

I 

OlO 

010 

X70 

X70 

030 

020 

N 

NIO 

NIO 

N70 

X70 

N30 

N20 

M 

MIO 

MIO 

X70 

X70 

M30 

M20 

P 

CIO 

CIO 

F70 

X7  0 

C30 

C20 

FOR  DEPENDENT  STATUS  NOT 

20 

SPONSOR 

STATUS 

BRANCH 

A 

B 

J 

N 

R 

V 

A 

A50 

A60 

A50 

E 

X70 

P60 

P2  0 

F 

F50 

F50 

X70 

X70 

F60 

F20 

I 

050 

050 

X70 

X70 

060 

X70 

N 

N50 

N50 

X70 

X70 

N60 

N20 

M 

M50 

M50 

X70 

X70 

M60 

M20 

P 

C50 

C50 

X70 

X70 

C60 

C20 

ALL  OTHER  CATEGORIES  ARE  X70  EXCEPT: 

If  Sponsor  Status  is  C  then  Category  is  X30 
If  Sponsor  Status  is  D  then  Category  is  KIO 


-52- 


If  Sponsor  Status  is  S  then  Category  is  X20 
If  Sponsor  Status  is  E  and  Dependent  Status 
is  20  then  Category  is  X20 


OTHER  ADDED  FIELDS 

SEQ  =  Sequence  number  used  as  the  eight  digit 
Litho  code. 

RACE  =  Blank 

DATE  =  Date  tape  was  converted 


DEERS  PROCESSING 

After  DEERS  data  was  converted  to  a  compatible 
format  with  the  ACDB  it  was  sorted  by  Social  Security 
number  and  FMP.  The  next  step  depended  on  whether  the 
data  was  to  be  added  to  the  mainframe  data  base  or  sent 
to  the  sites  for  inclusion  in  their  data  base.  A 
program  called  VSORT  in  the  partitioned  data  set  (PDS) 
DXB . ACDB . CNTL  was  used  to  sort. 

Mainframe  processing  at  this  step  continued  with 
the  program  PATD32  in  the  PDS  DXB. ACDB. CNTL.  This 
program  encrypted  the  Social  Security  number  and  added 
the  site  identification  code  to  each  record.  The  data 
was  then  loaded  into  the  FOCUS  patient  file  by  the  FOCUS 
procedure  PATILOAD  or  PATILD  located  in  the  PDS 
DXB. FOCEXEC. DATA.  The  PATILOAD  program  was  the  FOCUS 
procedure  originally  designed  to  load  the  Patient 
Registration  forms.  It  did  not  update  existing 
records.  PATILD  procedure  was  a  modified  version  of 
PATILOAD  which  allowed  for  information  to  be  updated 
within  a  patient's  record.  The  DEERS  data  was 
constantly  updated  because  of  moves  or  changes  in 
status.  The  continual  updating  created  another 
dilemma.  Should  the  record  contain  current  information 
regarding  patient  demographics,  or  should  it  contain 
information  which  was  correct  at  the  time  of  a 
particular  visit?  To  have  correct  information  at  the 
time  of  each  visit  would  require  multiple  records  for 
many  patients.  This  would  make  the  patient  file  even 
larger  and  would  require  a  date  key  for  access. 

Collecting  the  patient's  information  at  every  visit 
and  including  it  with  the  visit  data  would  have  been  one 
way  to  overcome  this  problem.  This  would  have  increased 
considerably  the  time  and  effort  required  to  collect 
this  information,  thus  defeating  one  of  the  objectives 
of  the  study  -  making  the  data  collection  as  painless  as 
possible.  Since  patient  registration  was  a  problem 
during  the  study,  this  solution  was  not  feasible. 


Processing  for  the  PCs  continued  by  downloading  the 
converted  and  sorted  DEERS  data  onto  Bernoulli  disk 
cartridges  which  were  sent  to  the  sites  for  loading  into 
each  site's  FOCUS  patient  files. 

Downloading  procedures  are  in  the  Mainframe 
section.  Also  note  that  all  programs  or  FOCUS 
procedures  are  listed  in  the  appendices. 
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6.0  FORT  DETRICK  PROCESSING 

Development  began  at  HCSCIA  at  Ft.  Sam  Houston  in 
San  Antonio,  Texas.  About  June  1985  the  programmer  left 
the  project  and  a  replacement  was  obtained.  The 
development  work  was  more  than  one  programmer  could 
handle  because  of  the  pressure  to  get  the  sites  up  and 
running.  In  August  1986  a  second  programmer  from  Ft. 
Detrick,  already  tasked  under  the  Performance 
Measurement  Study,  was  asked  to  help.  By  September  some 
sites  had  had  equipment  installed  and  programs  were 
ready  to  scan  a  few  forms.  The  second  programmer  then 
left  the  project  on  30  September  1985.  The  Ft.  Detrick 
programmer  continued  development,  working  at  HCSCIA 
about  50  percent  of  the  time  for  the  next  six  months. 
Eventually  a  PC  system  with  the  scanner  was  installed  at 
Ft.  Detrick  and  development  work  remained  there.  A 
second  PC  system  was  purchased  at  Ft.  Detrick  for 
uploading  data. 

Presently,  all  ACDB  accumulated  data  is  stored  on  a 
mainframe  computer  at  Ft.  Detrick  in  Frederick, 

Maryland. 

6.1  PC  PROCESSING  AT  DETRICK 

Two  PC  systems  were  eventually  installed  at  Ft. 
Detrick.  One  system  with  an  Iomega  Bernoulli  disk 
cartridge  system  and  a  Model  7001  NCS  scanner  was  used 
for  development.  The  second  system  was  used  for 
uploading  data  sent  in  by  the  sites  to  the  mainframe 
computer. 

6.1.1  UPLOADING  DATA 

Several  approaches  to  uploading  data  from  a  PC  to 
the  mainframe  computer  were  explored.  The  goal  was  to 
be  able  to  upload  data  in  the  fastest  time  possible. 
Details  of  each  approach  are  not  noted  here.  Technology 
is  constantly  being  developed  that  makes  old  techniques 
obsolete.  The  final  uploading  approach  used  an  IRMA 
board  manufactured  by  Digital  Communications  Associates, 
Inc.  Uploading  was  achieved  at  a  rate  of  2  million 
bytes  per  hour.  Today,  there  are  methods  that  are  more 
than  twice  as  fast. 

The  monthly  visit  data  sent  by  the  sites  ranged 
from  3  to  6  million  bytes,  thus  uploading  took  from  1.5 
to  3  hours  per  site.  With  SIDPERS  and  DEERS  data  being 
uploaded  and  downloaded,  the  second  PC  system  was  used 
about  40  hours  a  month  for  data  transfer. 
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6. 1.1.1  IRMA 


When  Installed  in  a  PC,  an  IRMA  board  allows  j 

bisynchronous  communication  between  the  PC  and  a 
mainframe.  Software  included  with  the  IRMA  board 
enabled  the  PC  to  simulate  a  mainframe  terminal.  FTTSO, 
a  file  transfer  program,  enabled  data  transfer  between 
the  TSO  operating  system  on  the  mainframe  and  a  PC. 

Also  needed  on  the  mainframe  was  a  resident  program 
provided  by  Digital  Communications  Associates  at  no 
charge . 

FTTSO,  a  menu  driven  program,  permitted  a  PC  file 
name  and  a  mainframe  file  name  to  be  entered.  Data 
Control  Block  (DCB)  information  could  also  be  entered 
letting  TSO  automatically  allocate  the  mainframe  file. 

Menus  containing  DCB  parameters  for  visit  data,  patient 
data,  provider  data,  clinic  data,  SIDPERS  data  and  DEERS 
data  were  stored  so  that  production  control  personnel 
could  follow  established  procedures  for  uploading  data. 

Details  of  the  uploading  and  downloading  procedures 
need  not  be  included  in  this  manual  since  IRMA 
documentation  is  available;  if  the  study  were  to  be 
started  up  again,  different  techniques  would  be  used. 

An  example  of  the  FTTSO  menu  is  provided  below  with  the 
Transfer  Parameter  section  included.  (t 

IRMAlink  FT/TSO  Ver.  2.10 
Copyright  1984  Digital  Communications  Associates 


PC  filename: 
Data  set  name: 
Transfer  type: 


Function  Keys 


1  SEND 

2  HELP 

3  RECV 

4  ERS  INP 

5SAVE  TY 

6  ERS  EOF 

7  RESTAR 

8  NXT  VAL 

9  EXIT 

10  RESET 

Transfer  Parameters 
Block  size:  Transfer  mode: 

Record  size:  Expands  TABs: 


Record  format: 


Line  numbers  - 
Position: 
Length: 

Code  table: 


Truncate  spaces: 

U/L  case: 

Volume  serial: 
Space  Units: 
Primary  qty: 
Secondary  qty: 
Directory  blocks: 


The  PC  file  name  is  entered  in  the  first  line  and 
the  mainframe  file  name  in  the  second  line.  The  last 
part  of  the  mainframe  file  name  automatically  is 

repeated  on  the  third  line  for  transfer  type  if  a  menu  I 

for  the  transfer  parameters  has  previously  been  created 
and  stored.  Thus  the  transfer  parameters  are  invoked  by 
the  mainframe  file  name.  For  example,  visit  data  from 
BAMC  had  a  mainframe  file  name  of  PMS . BAMC.JAN87 .VISIT. 

The  last  part  of  the  name,  VISIT  invoked  the  visit 

transfer  parameters  automatically  when  the  name  was  I 

entered.  The  operator  then  used  the  FI  function  key  to 

send  data  to  the  mainframe.  For  downloading,  the 

transfer  parameters  were  unnecessary. 

6.1.2  DEVELOPMENT 

I 

Development  of  PC  systems  for  the  ACDB  Study 
originally  began  at  HCSCIA  at  Ft.  Sam  Houston,  Texas.  A 
IBM  XT  with  256K  memory,  a  lOM  byte  hard  drive  and  an 
Iomega  Bernoulli  10+10  external  drive  was  delivered  to 
Ft.  Detrick,  Maryland,  early  in  the  study.  The  Ft. 

Detrick  system  was  to  be  used  generally  for  uploading  I 

data.  Specific  details  of  how  this  was  to  be  done  had 

to  be  formulated.  After  the  first  two  programmers  at 

HCSCIA  left  the  study,  a  Ft.  Detrick  programmer  took 

over  the  software  area  of  the  project.  For  several 

months,  September  1985  to  March  1986,  half  of  the 

programming  effort  was  done  at  HCSCIA  using  the  IBM  XT  ' 

and  NCS  Scanner  Model  Sentry  7001.  FOCUS,  the  DBMS  was 
also  available  on  this  system.  Eventually,  the  Ft. 

Detrick  system  was  expanded  by  adding  FOCUS,  which 
included  a  memory  board  and  brought  the  total  memory  to 
768K  bytes.  The  NCS  scanner  was  shipped  from  HCSCIA  to 
Ft.  Detrick,  providing  a  total  system  capable  of  all  the 
software  development  needs  of  the  study. 

Early  in  the  study  the  primary  goal  of  system 
development  was  to  have  a  minimum  system  capable  of 
scanning  forms  and  storing  data.  Most  of  the  Basic 
programs  to  scan  forms  were  written  but  not  tested. 

During  the  change  of  programmers,  the  fact  that  programs 
were  untested  was  overlooked  until  the  sites  began  to 
have  problems  in  scanning.  Correctly  completed  forms 
were  rejected.  Additionally,  some  data  was  not 
collected  properly,  and  these  errors  made  their  way  into 
the  data  base.  It  wasn't  until  December  of  1985  that 
most  of  the  bugs  were  worked  out.  All  data  collected 
prior  to  January  1,  1986,  has  been  set  aside  and  will 
not  be  used  in  analysis. 

During  this  time  there  were  still  new  programs 
being  written  as  new  forms  were  being  designed.  FOCUS 
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programs  were  also  needed  to  give  the  sites  reporting 
capabilities.  To  aid  in  the  success  of  the  project,  an 
attempt  was  made  to  provide  a  useful  product  early  in 
the  study.  Two  FOCUS  contractors  from  IBI  were  hired 
primarily  to  develop  a  series  of  FOCUS  reporting 
programs.  Twelve  general  reports  were  considered  to  be 
appropriate,  and  about  eight  were  completed.  In 
addition,  FOCUS  courses  were  given  by  the  contractors  to 
ACDB  personnel. 

Development  continued  through  1986.  The  programmer 
also  provided  technical  support  to  local  study  sites 
during  this  time.  A  few  new  forms  were  designed,  and 
programs  had  to  be  written  for  them.  No  fewer  than  ten 
updates  were  sent  to  the  sites  during  1986.  Some 
included  new  description  files,  some  new  programs  and 
some  fixes  to  problems.  There  was  also  a  problem  of 
time.  It  was  soon  discovered  that  FOCUS  took  a  good 
deal  of  time  to  load  data  and  produce  reports  from  the 
monthly  data.  Tuning  the  system  to  make  it  more 
efficient  became  a  critical  requirement.  Site  operators 
were  not  able  to  keep  up  with  scanning  forms  as  the 
numbers  received  from  the  clinics  increased.  There  were 
not  enough  hours  in  the  day  to  scan,  load  data  and  run 
reports.  Several  remedies  were  taken. 

One  remedy  was  to  relax  some  of  the  rigorous  edits 
on  each  of  the  forms.  Although  some  data  elements  might 
not  be  as  clean,  the  forms  would  scan  faster,  and  less 
time  would  be  needed  by  the  site  operators  to  sort 
through  the  rejects  and  correct  them  or  send  them  back 
to  the  clinics  for  correction.  Relaxed  edits  probably 
resulted  in  more  data  collected  even  though  some  of  it 
may  be  in  error.  Under  rigorous  edits  some  forms 
returned  to  the  clinic  for  correction  never  made  their 
way  back  to  be  input;  thus  the  data  for  the  entire  form 
was  lost. 

To  relax  the  edits,  resolution  sheets  for  each  form 
had  to  be  changed  and  tested.  To  save  time  the  first 
five  pages  of  the  scanner  resolution  sheets  were  shared 
among  all  the  forms.  These  five  pages  were  nearly 
identical  except  for  certain  forms.  Therefore  an 
exception  had  to  be  made  on  these  pages  and  care  taken 
to  insure  the  pages  were  coded  for  the  proper  form. 
Unavoidable  errors  caused  problems  at  the  sites;  these 
problems  had  to  be  resolved.  Solutions  had  to  be  tested 
and  another  update  sent  out.  By  the  end  of  1986  all 
pages  of  the  resolution  sheets  were  completed,  and  these 
kinds  of  errors  were  eliminated. 

Development  efforts  to  improve  efficiency  continued 


throughout  the  year.  Most  FOCUS  report  programs  were 
rewritten  entirely  to  make  them  more  efficient.  A  night 
reporting  system  (beginning  in  late  1985)  allowed  report 
programs  to  be  queued  and  run  at  night.  Since  the 
printer  needed  to  be  monitored  in  case  of  jams,  the 
night  reports  were  printed  out  during  the  day. 
Experiments  changing  the  location  of  FOCUS  and  data 
bases  on  the  disk  drives  were  made.  Most  changes  of 
this  nature  caused  more  operational  problems  negating 
any  benefit  of  time  saved. 

Another  development  effort  during  1986  was  the 
implementation  of  the  SIDPERS  and  DEERS  data  bases  for 
patient  registration. 

Throughout  the  year  FOCUS  was  being  improved,  and 
two  upgrades  were  received  and  installed  at  the  sites. 

If  a  system  is  working  smoothly,  it  is  not  necessary  to 
install  upgrades,  but  there  were  major  problems  in  each 
FOCUS  version  or  upgrade  that  made  it  desirable  to 
install  improved  versions.  Although  some  of  the  old 
problems  were  solved,  new  problems  occurred.  These  new 
problems  took  some  effort  to  trace  the  causes  and 
correct  them.  As  time  went  on,  there  were  fewer  FOCUS 
problems  (or  techniques  were  found  to  circumvent  them) . 
One  problem  which  occurred  late  in  the  year  caused  the 
computer  to  freeze.  The  only  solution  was  to  turn  the 
computer  off  and  then  back  on.  Of  course,  the  operator 
had  to  reenter  FOCUS  and  start  over  again  with  whatever 
task  was  being  performed.  The  cause  was  partially  the 
poor  memory  management  portion  of  FOCUS,  but  the  problem 
was  overcome  by  upgrading  to  the  next  level  of  DOS. 
Although  the  problem  did  not  entirely  disappear,  it  was 
manageable . 

Disk  space  became  critical  as  patient  registration 
files  grew  rapidly  with  the  SIDPERS  and  DEERS  data  being 
used  to  supplement  form  registrations.  This  and  the 
desire  for  more  efficiency  brought  about  the  decision  to 
upgrade  the  hardware  at  each  site.  An  additional  PC 
system  was  installed  at  each  site  except  Redstone 
Arsenal.  One  system  was  devoted  to  scanning,  and  the 
other  was  used  for  data  base  operations  such  as  loading, 
reporting  and  preparing  data  for  shipment.  Development 
effort  was  required  to  split  the  single  system  into  two 
systems.  Along  with  this  hardware  installation,  the 
upgrading  of  the  Imomega  Bernoulli  lOM  byte  drives  to 
20M  drives  was  done.  The  initial  site  to  upgrade  to  new 
hardware  was  Ft.  Campbell  in  September  1986. 

The  last  major  effort  in  development  occurred  in 
the  first  five  months  of  1987.  All  forms  except  for  the 


registration  forms  were  completely  redesigned.  This 
meant  all  resolution  programs  had  to  be  rewritten  along 
with  all  the  Basic  programs  used  to  scan  each  form. 

FOCUS  changes  were  required  since  some  fields  in  the 
data  base  were  no  longer  collected,  and  there  were  some 
new  fields.  A  temporary  employee  was  hired  at  Ft. 
Detrick  during  this  time  to  help  in  the  redesign 
development.  New  techniques  were  used  particularly  in 
the  scanning  portion.  Rather  than  code  the  resolution 
sheets  by  hand,  a  program  was  obtained  from  NCS  to  code 
them  by  data  entry  on  the  computer.  Continuous 
resolution  sheet  forms  were  obtained,  and  the  new  sheets 
were  printed  directly  from  the  computer  using  special 
ribbons.  The  advantage  of  this  method  was  that  the 
great  amount  of  duplication  of  fields  on  many  forms 
could  be  handled  easily  by  computer,  saving  many  hours 
of  hand  coding.  The  disadvantage  was  that  the  printing 
of  the  resolution  sheets  was  critical,  and  in  many  cases 
extra  time  was  spent  getting  the  scanner  to  read  them. 
New  techniques  available  now  allow  the  entire  process  to 
remain  in  the  computer,  eliminating  the  need  for 
resolution  sheets  and  scanner  programs. 

The  natural  course  of  events  after  any  major  change 
(or  minor  for  that  matter)  is  to  work  out  the  bugs  after 
installation.  Experience  and  more  thorough  testing  kept 
problems  to  a  minimum  the  second  time  around. 

Development  effort  essentially  ended  by  July  of 
1987  as  far  as  the  data  collection  portion  of  the  study 
was  concerned. 

6.1.3  TECHNICAL  SUPPORT 

Technical  support  was  also  provided  by  Ft. 

Detrick.  Technical  support  included  aid  in  diagnosing 
hardware  and  software  problems  on  the  scanner  and  IBM  XT 
systems.  Most  problems  were  solved  or  their  causes 
determined  by  telephone.  On  a  few  occasions  listings  or 
diskettes  were  sent  to  Ft.  Detrick  for  analysis.  One  or 
two  cases  required  a  site  visit. 

Support  by  telephone  has  its  disadvantages. 

Solving  programming  and  hardware  problems  depends  on 
visual  clues.  Two  approaches  can  be  taken,  and  the 
final  solution  is  usually  a  combination  of  these 
approaches.  The  first  approach  is  to  examine  the 
symptoms  and  obtain  clues  that  point  to  another  area 
which  may  be  causing  the  problem.  The  second  is  to 
eliminate  areas  of  possible  causes  by  examining  symptoms 
and/or  testing  them  independently.  Either  method 
depends  on  a  logical  step-by-step  process.  Directories, 
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listings,  and  error  messages  are  types  of  data  that  must 
be  scanned.  Usually  the  eye  of  an  experienced 
progrananer  can  pick  out  an  unusual  sequence  of 
characters  or  some  other  clue  from  listings  or  screens 
of  data.  This  cannot  be  done  over  the  telephone.  Data 
must  be  read.  Instructions  must  be  given  to  execute  DOS 
or  other  commands  that  may  not  be  familiar  to  the 
operator.  Commands  usually  are  required  to  be  spelled 
since  they  are  not  English  words.  Then  letters  such  as 
's'  or  'f  are  easily  misunderstood.  Debugging  by 
telephone  can  be  a  long  and  tedious  process. 

Testing  on  another  machine  by  running  the  same  task 
or  examining  copies  of  programs  is  also  helpful.  A 
telephone  headset  was  purchased  to  allow  the  hands  to  be 
free  to  test  options  while  continuing  to  talk  on  the 
telephone.  Time  spent  on  the  telephone  each  week 
probably  averaged  15  to  20  hours.  In  many  cases 
programming  problems,  if  found  at  one  site,  were 
resident  at  all  sites.  Thus  each  site  had  to  be 
contacted  and  warned.  Usually  this  meant  not  scanning  a 
particular  form  or  not  running  a  particular  report,  and 
it  did  not  stop  the  entire  operation.  In  some  cases  the 
solution  could  be  given  over  the  telephone  but  in  many 
cases  update  diskettes  had  to  be  sent  out.  Update 
diskettes  were  usually  sent  out  on  a  monthly  basis. 

It  was  through  the  cooperation  and  patience  of  site 
personnel  that  so  much  was  accomplished  by  telephone. 

At  the  beginning  of  the  study  many  operators  were  weak 
in  DOS  and  FOCUS,  and  their  willingness  to  listen  to 
step-by-step  procedures  and  explain  results  over  the 
telephone  was  admirable.  As  the  study  progressed,  the 
operators'  experience  and  knowledge  of  the  equipment  and 
system  programs  increased,  making  debugging  easier  and 
less  time  consuming. 

Describing  the  details  of  all  the  problems  is  not 
productive,  but  some  items  may  be  of  interest.  A 
maintenance  contract  with  NCS  provided  servicing;  if  any 
hardware  failure  occurred,  it  was  to  be  repaired  or 
replaced.  The  field  engineers,  while  experienced  in 
scanner  maintenance,  were  weak  in  the  IBM  and  Iomega 
equipment.  Many  times  the  field  engineer  had  to  be  told 
what  to  replace  after  our  own  diagnosis.  When  the 
additional  IBM  systems  were  added  in  the  fall  of  1987, 
many  of  the  field  engineers  called  Ft.  Detrick  rather 
than  NC3  to  ask  about  the  installation  procedure.  There 
were  some  stit-ky  scanner  problems,  and  in  some  cases  the 
wrong  part  was  sent.  Overall,  NCS  provided  good 
support,  and  equipment  was  usually  replaced  or  repaired 
within  24  hours. 
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Feeding  of  the  sheets  into  the  scanner  caused  some 
early  problems  until  a  scanner  procedure  called  'double 
sheet  calibration'  was  discovered.  This  procedure 
calibrates  the  double  sheet  indicator  and  is  unic[ue  for 
each  scanner.  For  some  reason  the  site  operators  did 
not  know  about  this  procedure  and  put  up  with 
considerable  grief  trying  to  scan  without  jams.  It  was 
either  through  some  operator  reading  the  manuals  or  a 
field  engineer  making  a  suggestion  that  this  procedure 
solved  most  of  the  jamming  problems. 

Technical  support  was  provided  throughout  the  study 
along  with  development.  While  time  consuming,  it  was 
aided  by  the  cooperation  of  the  site  personnel. 

6. 1.3.1  OPTIMIS 

OPTIMIS  (Operation  Management  Information 
Management  System)  of  the  Department  of  the  Army 
provided  an  electronic  mail  capability.  Each  site  had  a 
built-in  modem  which  could  be  used  to  dial  into  OPTIMIS. 

The  electronic  mail  facility  was  very  helpful  in 
maintaining  coinmunications  among  the  sites,  HCSCIA  and 
Ft.  Detrick.  It  was  not  always  possible  to  reach 
personnel  by  telephone  because  of  time  zones  and  varying 
work  hours.  It  was  desirable  to  reach  the  sites  as 
quickly  as  possible  when  a  system  error  affected  all 
sites.  OPTIMIS  provided  a  distribution  list 
capabability  which  allowed  messages  to  be  sent  to  all 
sites  simultaneously. 

The  advantages  of  OPTIMIS  were  (1)  messages  could 
be  sent  at  any  time  (2)  messages  could  be  read  when 
convenient  (3)  messages  could  be  sent  simultaneously  to 
all  sites  by  distribution  lists  (4)  written 
instructions  could  be  sent  making  interpretation 
clearer  (5)  written  instructions  could  be  studied,  and 
(6)  the  messages  could  be  printed  and  saved  for  later 
reference.  While  the  advantages  of  providing  technical 
support  by  telephone  have  been  expounded  above, 
electronic  mail  also  was  critical  and  helped 
considerably  in  resolving  and  correcting  problems. 

An  OPTIMIS  account  was  obtained  for  all  site 
personnel  and  for  most  of  the  HCSCIA  staff  working  on 
the  project.  Communications  between  HCSCIA  and  Ft. 
Detrick  were  made  more  convenient  by  OPTIMIS. 

6 . 2  MAINFRAME  COMPUTER 

The  mainframe  computer  at  Ft.  Detrick  is  an  AMDAHL 


470/V8  (IBM  3033  compatible)  with  16  megabytes  of 
memozy  and  16  data  channels.  It  is  capable  of  executing 
6.9  million  instructions  per  second. 

Direct  access  storage  is  constantly  growing.  At 
the  time  of  the  data  collection  portion  of  the  ACDB 
Study  there  were  six  IBM  3380  units  with  2.5  gigabytes 
each.  In  addition  there  were  16  IBM  3350  disk  drives 
with  317.5  megabytes  each  as  well  as  16  IBM  3330-11 
units  with  200  megabytes  each. 

There  are  eight  STC  4670  tape  units  with  1600/6250 
BPI  capability  as  well  as  two  IBM  2401  units  with 
800/1600  BPI  capability.  Two  IBM  1403  printers  are  on 
line,  capable  of  printing  1100  lines  per  minute  each.  A 
COMTEK  3690  communications  controller  with  32 
bisynchronous  ports  and  96  asynchronous  ports  is  also 
available. 

6.2.1  TSO/ISPF  ENVIRONMENT 

Several  operating  systems  reside  on  the  mainframe 
computer.  The  Time  Sharing  Option  (TSO)  is  used  by  the 
study.  It  is  an  interactive  terminal  system  which 
allows  the  user  conversational  access  to  the  facilities 
of  the  computer.  Knowledge  of  TSO  commands  is  necessary 
to  operate  within  this  system. 

Under  TSO  is  a  package  called  ISPF  (Integrated 
System  Productivity  Facility)  which  extends  the 
capabilities  of  TSO.  ISPF  has  full  screen  editing 
commands  with  split  screen  capability.  Most  of  the  TSO 
commands  are  presented  as  menu  options.  The  menu 
options  make  the  system  more  user  friendly  and  make 
learning  the  TSO  commands  unnecessary.  Basic 
familiarity  with  the  operating  system  and  file 
structures  is  necessary  if  utility  and  development 
efforts  such  as  setting  up  FOCUS  areas  are  to  be  carried 
out. 


Online  sessions  as  well  as  batch  jobs  may  be  run. 
FOCUS  may  be  used  in  both  modes.  JCL  (Job  Control 
Language)  knowledge  is  necessary  for  submitting  batch 
jobs. 


There  are  several  program  languages  and  data  base 
management  systems  available  on  the  mainframe  computer. 
Two  such  systems  used  by  the  study  are  SAS  and  FOCUS. 

It  is  not  the  purpose  of  this  manual  to  give  a 
detailed  explanation  of  TSO,  ISPF,  or  JCL.  There  are 
IBM  manuals  available  on  these  subjects.  There  are  also 
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manuals  for  SAS  and  FOCUS.  However,  where  detailed 
explanations  may  help  in  understanding  how  the  ACDB  data 
processing  procedures  are  used  within  the  system,  they 
are  given. 

6.2.2  MAINFRAME  FOCUS 

Mainframe  FOCUS  is  similar  in  many  ways  to  PC  FOCUS 
particularly  in  writing  report  requests.  However,  there 
are  many  differences  that  can  cause  problems  for  the 
casual  user  without  mainframe  experience.  Differences 
between  mainframe  FOCUS  and  PC  FOCUS  are  not  explained 
here,  but  explanations  of  how  to  apply  FOCUS  techniques 
for  applications  used  in  the  ACDB  Study  are  furnished. 

FOCUS  runs  under  the  TSO  ISPF  operating  system 
environment.  Thus  a  knowledge  of  some  TSO  is  necessary 
for  the  FOCUS  user.  TSO  commands  may  be  used  within 
FOCUS  procedures.  Other  maintenance  activities  require 
TSO  intervention.  Debugging  and  monitoring  programs  can 
be  done  through  TSO.  Batch  jobs  require  JCL  knowledge. 
In  a  thoroughly  developed  system  where  all  programs  are 
written  and  tested,  the  user  can  be  sheltered  from  much 
of  the  background  knowledge  such  as  TSO  or  JCL.  In  this 
study  where  the  design  characteristics  evolved 
throughout  the  data  collection  period  and  where  analysis 
of  the  data  led  in  different  directions  depending  on  the 
outcome  of  the  results,  a  closed  system  was  not 
developed.  Thus  the  researcher  using  the  data  must  be 
familiar  with  mainframe  operating  systems  as  well  as 
FOCUS.  In  addition  he  or  she  must  be  aware  of  the  data 
collection  techniques  and  problems  of  the  study  in  order 
to  analyze  the  data  and  assess  the  results  properly. 

There  are  three  file  types  in  FOCUS,  and  on  the 
mainframe  these  files  are  stored  in  different  areas. 
There  must  be  a  file  description,  the  data  file,  and  the 
FOCUS  procedures  or  programs.  The  PC  distinguishes  the 
type  of  file  by  assigning  an  extension  for  each  type. 

The  mainframe  stores  master  files  and  procedures  in 
partitioned  data  sets  (PDS) .  The  PDS  for  master  files 
is  called  PMS . MASTER . DATA .  The  PDS  for  FOCUS  procedure 
files  is  called  FOCEXEC . DATA .  The  FOCEXEC.DATA  PDS  is 
user  specific.  In  other  words  each  user  has  his  own 
FOCEXEC  PDS .  The  PDS  name  is  preceded  with  the  user ' s 
ID,  for  example:  DXB . FOCEXEC . DATA .  The  master  and  data 
files  are  common  to  all  users  and  have  a  general  user 
prefix.  The  general  user  prefix,  PMS,  stands  for 
Performance  Measurement  Study,  of  which  the  ACDB  Study 
is  a  part. 

A  PDS  is  similar  in  some  ways  to  a  subdirectory  on 
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a  PC.  Many  files  may  reside  within  a  PDS  and  are  called 
members.  The  data  base  files  are  not  in  a  PDS  and  the 
structure  parameters  must  correspond  to  the  requirements 
of  FOCUS.  The  names  of  the  data  base  files  end  in 
FOCUS.  An  example  of  the  visit  file  for  BAMC  is 
PMS.VBAMC. FOCUS. 

6.2.3  FOCUS  PROGRAMS 

Most  of  the  FOCUS  procedures  written  for  the 
mainframe  are  data  loading  programs.  These  are  FOCUS 
modify  procedures  and  are  very  similar  to  the  PC 
versions  in  many  cases.  Reporting  procedures  written 
for  the  mainframe  are  mostly  ad  hoc  programs  written 
when  some  analysis  of  the  data  is  required.  The  FOCUS 
procedures  are  members  of  a  FOCEXEC.DATA  partitioned 
data  set. 

6 . 2 . 3 . 1  LOADING  PROGRAMS 

FOCUS  Modify  procedures  were  used  to  load  raw  data 
into  FOCUS  stuctured  hierarchical  files.  The  mainframe 
load  program  loaded  visit  data  into  FOCUS  files  sent  in 
each  month  from  the  sites  simililar  to  the  PC  programs 
that  loaded  scanned  data  into  FOCUS  files.  Other  data 
which  needed  loading  was  the  patient  registration  data. 
This  was  sent  periodically  from  the  sites  and 
supplemented  by  the  SIDPERS  and  DEERS  data.  P. jvider 
registration  data  from  the  sites  was  also  periodically 
updated.  Code  descriptions  such  as  Clinic  descriptions. 
Diagnosis  descriptions,  Procedure  descriptions  and  Other 
code  descriptions  initially  required  loading  and 
occasionally  updating  to  incorporate  corrections  and 
additions. 

Listings  of  the  loading  programs  are  provided  in 
Appendix  E.  A  visit  loading  procedure  was  written  for 
each  site.  They  are  the  same  except  for  the  input  and 
output  file  names.  The  appendix  includes  an  example  of 
a  visit  procedure  for  the  new  data  (after  the  form 
revision  in  May  1987) .  The  data  at  each  site  was  dumped 
by  a  FOCUS  Table  Request  which  created  a  file  nearly 
identical  to  the  raw  data  initially  supplied.  Thus  the 
visit  load  procedure  for  the  mainframe  was  similar  to 
the  PC  version  except  for  the  areas  concerning  computer 
architecture. 

Listings  provided  in  the  appendix  are 

LBAMC  Loading  procedure  for  visit  data 

PATILOAD  Loading  procedure  for  patient  data 
PROVLOAD  Loading  procedure  for  provider  data 
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PROCLOAD  Loading  procedure  for  procedure  code 
descriptions 

DIAGLOAD  Loading  procedure  for  diagnosis  code 
descriptions 

OTHIX)AD  Loading  procedure  for  other  code 
descriptions 

6 . 2 . 3 . 2  REPORTING  PROCEDURES 

Reporting  procedures  are  called  Table  Requests  by 
FOCUS.  No  mainframe  Table  Requests  are  included  since 
no  standard  procedures  were  generated  for  the  study.  A 
warning  may  be  given  here  as  may  have  been  stated 
elsewhere  in  this  manual. 

FOCUS,  a  fourth  generation  language,  makes  it  easy 
to  write  Table  Requests.  However,  without  a  knowledge 
of  the  hierarchical  structure  of  the  data  base  and  the 
behind  the  scenes  operation  of  FOCUS  statements,  an 
incorrect  report  can  be  created  more  easily  than  a 
correct  one.  An  experienced  programmer  tests  procedures 
on  known  data  to  insure  accuracy  before  releasing 
results  from  a  data  base.  The  simplicity  of  FOCUS  Table 
Requests  lures  the  novice  into  a  false  sense  of 
accomplishment  when  sophisticated- looking  reports  are 
generated  even  though  the  results  may  be  inaccurate. 

Another  caveat  concerns  execution  time.  On  a  large 
data  base,  a  FOCUS  procedure  may  take  hours  to  run.  The 
large  amounts  of  time  required  for  loading  and  running 
reports  on  the  PC  have  already  been  mentioned.  Even 
though  the  mainframe  is  much  faster  than  the  PC, 
procedures  still  may  take  hours  to  run.  One  reason  for 
this  is  that  the  data  base  is  now  much  larger, 
consisting  of  data  from  the  six  sites  accumulated  over 
the  life  of  the  study.  Another  cause  is  inefficient 
writing  of  procedures.  As  in  all  programming  languages, 
there  is  more  than  one  way  to  do  a  given  task.  When 
there  are  multiple  ways  to  do  a  task,  one  way  is  usually 
more  efficient.  Knowledge  of  FOCUS  internals  helps  in 
designing  efficient  procedures. 

6. 2. 3. 3  RUNNING  BATCH  PROGRAMS 

Running  a  FOCUS  procedure  on  a  large  data  base  can 
be  time  consuming.  It  is  not  convenient  to  attempt  to 
run  large  jobs  on-line.  Further,  some  procedures 
generate  large  reports  which  sometimes  can  be  printed 
more  conveniently  through  a  batch  job.  A  batch  job  is 
run  in  a  background  time-sharing  mode.  When  a  FOCUS  job 
is  submitted,  various  work  areas  must  be  reserved 
(allocated) .  In  addition,  an  assessment  must  be  made  of 
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the  data  bases  needed  for  a  report.  The  JCL  must  be 
written  to  convey  to  the  computer  all  the  information 
necessary  to  carry  out  the  reporting  task.  An  example 
of  a  batch  job  JCL  to  run  a  FOCUS  procedure  is  given 
below: 


7DXB1Z  JOB  PlOl, BOLLING, CLASS=F,MSGCLASS=X,MSGLEVEL= (2, 
ySTEPl  EXEC  PGM=FOCUS,REGION=4096K 


//STEPl  EXEC 
//STEPLIB  DD 
//ERRORS  DD 
//FOCSTACK  DD 
//FOCSORT  DD 
//HOLDMAST  DD 
//HOLD  DD 

//SYSPRINT  DD 
//OFFLINE  DD 
//MASTER 
//FOCEXEC 
//VBAMC 
//VBRAG 
//VCAMP 
//VJACK 
//VPOLK 
//VREDS 
//CLINIC 
//DIAGNOS 
//PROVIDER  DD 
//PROCEDUR  DD 
//SYSIN  DD 
SET  PASS=XXXXX 
SET  BINS=64 
EX  AZT 
FIN 
/* 

// 


0) 


DD 

DD 

DD 

DD 

DD 

DD 

DD 

DD 

DD 

DD 


PGM=FOCUS , REGION=4096K 
DSN=SYS2 . FOC503 . FOCLIB . LOAD , DISP=SHR 
DSN=SYS2 . FOC503 . ERRORS . DATA, DISP=SHR 
UNIT=SYSDA,SPACE=(TRK, (1,1) ) 
UNIT=SYSDA,SPACE=(CYL, (6,6) ) 
UNIT=SySDA , SPACE= ( TRK ,(1,1,1)) 
UNIT=SYSDA,SPACE=(CYL, (20,20)) 
SYSOUT=* 

SYSOUT=* 

DSN=PMS . MASTER. DATA, DISP=SHR 
DSN=DXB. FOCEXEC. DATA, DISP=SHR 
DSN=PMS . VBAMC . FOCUS , DISP=SHR 
DSN=PMS . VBRAG . FOCUS , DISP=SHR 
DSN=PMS . VCAMP . FOCUS , DISP=SHR 
DSN=PMS .VJACK. FOCUS , DISP=SHR 
DSN=PMS . VPOLK . FOCUS , DISP=SHR 
DSN=PMS . VREDS . FOCUS , DISP=SHR 
DSN=PMS . CLINIC. FOCUS , DISP=SHR 
DSN=PMS . DIAGNOS . FOCUS , DISP=SHR 
DSN=PMS . PROVIDER. FOCUS , DISP=SHR 
DSN=PMS . PROCEDUR . FOCUS , DISP=SHR 
* 


Statements  beginning  with  //  or  /*  are  JCL 
statements.  The  first  statement  is  the  JOB  card 
(carried  over  from  the  days  when  jobs  were  submitted  on 
punched  cards) .  This  identifies  the  user,  gives 
accounting  information,  and  tells  the  computer  other 
information  needed  to  run  the  job. 

The  next  three  statements  assign  a  work  region  and 
call  FOCUS.  The  following  four  statements  allocate  disk 
space  for  FOCUS  work  areas.  Some  critical  space  areas 
are  FOCSORT  and  HOLD.  A  procedure  that  produces  a  large 
report  may  require  additional  disk  space  for  sorting. 
Other  procedures  may  create  temporary  files  called  HOLD 
files.  Should  these  be  large,  additional  space  may  need 
to  be  allocated.  Notice  these  lines  have  a  SPACE 
parameter  which  is  used  to  allocate  disk  space  in  tracks 
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or  cylinders. 


The  other  DD  statements  are  mostly  statements  that 
allow  FOCUS  to  recognize  data  bases  required  for  the 
FOCUS  procedure  being  executed.  In  the  example,  visit 
data  for  each  site  (VBAMC,  VBRAG,  VCAMP,  VJACK,  VPOLK 
and  VREDS)  as  well  as  some  of  the  description  files, 
CLINIC,  DIAGNOS,  and  PROCEDUR  are  mentioned.  If  the 
file  is  to  be  used  in  the  procedure,  it  must  be 
mentioned  in  the  JCL;  however,  if  a  file  is  mentioned 
and  not  used,  no  harm  is  done.  A  generic  JCL  file  can 
be  maintained  which  includes  all  the  input  data  base 
files.  This  reduces  editing  effort  every  time  a  new 
batch  job  is  needed. 

The  last  few  lines  with  no  //  or  /*  at  the 
beginning  are  FOCUS  statements.  These  are  identical  to 
on-line  FOCUS  statements.  In  the  example  the  first  line 
sets  the  password.  This  is  critical  should  the  data 
base  files  be  protected  by  a  data  base  administrator 
(DBA) .  No  data  will  be  read  unless  a  correct  password 
is  given.  The  second  SET  statement  assigns  the  number 
of  BINS.  The  maximum  number  is  64.  BINS  are  work  areas 
or  buffers  that  FOCUS  uses  for  I/O  ( input/ output 
tasks) .  Where  space  is  available,  a  maximum  setting 
usually  is  most  efficient.  The  next  statement,  EX  AZT, 
requests  that  the  procedure  AZT  be  executed.  Lastly  a 
FIN  statement  exits  FOCUS. 

The  previous  example  can  be  used  for  most  batch 
jobs  but  certain  procedures  may  require  additional  JCL 
or  modifications  to  statements  given.  If  a  FOCUS 
procedure  uses  a  FOCUS  library  routine,  the  following 
lines  are  needed: 

//USERLIB  DD  DSN=SYS2 . FOC503 . FOCLIB. LOAD, DISP=SHR 
//  DD  DSN=SYS2.FOC503.FUSELIB.LOD,DISP=SHR 

In  cases  where  data  is  to  be  appended  to  a  hold 
file,  DISP=MOD  should  be  added  to  the  HOLD  statement. 
Care  should  be  taken  to  remove  this  modification  in 
procedures  that  do  not  require  it. 

Batch  files  are  usually  prepared  in  a  PDS  other 
than  a  FOCEXEC.DATA  PDS,  However,  they  can  reside  in 
the  FOCEXEC  area.  Batch  files  may  be  submitted  by 
bringing  the  file  up  under  the  TSO  editor  or  in  the 
FOCUS  editor  (TED)  and  issuing  the  submit  command  (SUB) . 

6.2.4  SAS  PROGRAMS 

SAS,  which  stands  for  Statistical  Analysis  System, 
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is  a  product  supplied  by  SAS  Institute  Inc.  In  addition 
to  its  strong  statistical  capabilities,  it  can  be  used 
for  many  utility  and  maintenance  operations  that 
supplement  the  TSO  operating  system.  A  detailed 
explanation  of  SAS  is  not  given  in  this  manual  as  there 
are  a  number  of  SAS  manuals  available. 

SAS  is  very  powerful  in  its  statistical 
capability.  It  can  therefore  complement  FOCUS  when 
sophisticated  statistical  analysis  is  reguired.  FOCUS 
can  create  seguential  output  files  with  subsets  of  a 
data  base  which  can  then  be  used  as  input  files  to  SAS. 

SAS  has  been  used  to  inspect  and  repair  damaged 
files  received  from  the  sites. 

6.2.5  DEERS  AND  SIDPERS  PROCESSING 

Two  SAS  programs  have  been  written  that  have  been 
used  on  a  regular  basis.  These  programs  convert  the 
SIDPERS  and  DEERS  data  and  format  it  for  input  into  the 
FOCUS  Patient  data  base.  A  description  of  SIDPERS  and 
DEERS  data  usage  is  presented  under  the  Patient 
Registration  section  in  Special  Topics  of  this  manual. 
The  two  programs  are  SIDCONV  and  DEERS.  Listings  of  the 
programs  are  in  the  appendix. 

SIDPERS  tapes  were  received  and  copied  to  disk 
under  the  name  DXB.site.mmmyy.SIDATA.  Site  is  a  four 
letter  code  representing  the  ACDB  site  from  which  the 
data  was  received  (BAMC,  BRAG,  CAMP,  JACK,  REDS,  or 
POLK) .  The  three  character  month  abbreviation  and  last 
two  digits  of  the  year  were  inserted  in  the  mmmyy 
field.  The  data  was  sorted  by  Social  Security  number. 

A  copy  of  the  data  was  downloaded  for  PC  processing. 

The  mainframe  processing  continued  by  converting  the 
data  using  the  SIDCONV  program.  SIDCONV  converted  the 
data  and  added  a  site  identification.  It  also  encrypted 
the  Social  Security  number.  The  output  was  compatible 
with  the  FOCUS  patient  load  program,  PASILO.  PASILO 
loaded  the  data  into  the  patient  file,  PATIENT. FOCUS.  A 
listing  of  PASILO  is  in  the  appendix. 

DEERS  tapes  were  received  and  copied  to  disk.  The 
data  was  converted  by  the  DEERS  SAS  program  and  sorted 
by  Social  Security  number.  The  conversion  program 
converts  DEERS  data  fields  into  fields  compatible  with 
the  ACDB  study.  A  site  identification  code,  as  in  the 
SIDPERS  files,  is  added.  At  this  stage  the  data  is 
downloaded  and  sent  to  the  sites  for  loading  into  the  PC 
data  bases.  Mainframe  processing  continued  with  Social 
Security  number  encryption  and  loading  into  the  FOCUS 
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patient  file  using  PATILOAD.  A  listing  of  DEERS  is  in 
the  appendix. 

6.2.6  DOWNLOADING 

Downloading  of  files  from  the  mainframe  to  a  PC  was 
accomplished  using  the  IRMA  FTTSO  program.  A  mainframe 
program  provided  the  linkage  needed  to  access  mainframe 
files.  A  description  of  FTTSO  is  given  in  the  PC 
Uploading  section  of  this  manual.  Downloading  was 
simpler  than  uploading  as  no  data  control  block 
parameters  were  needed.  All  that  needed  to  be  done  was 
to  invoke  the  FTTSO  program,  enter  the  PC  and  mainframe 
file  names,  and  hit  the  F3  function  key  to  receive  the 
data. 

6.3  SITE  ACCESS  TO  MAINFRAME 

Limitations  of  disk  storage  space  on  the  PCs  at 
each  site  prevented  easy  access  to  more  than  one  month's 
data.  Several  sites  could  see  an  advantage  for  doing 
longitudinal  reports.  Some  providers  liked  a  record  of 
the  number  of  patients  seen  and  the  reasons  for  seeing 
them.  There  were  two  ways  this  could  be  accomplished 
using  the  accumulated  data  on  the  mainframe. 

Requests  for  reports  could  be  made  by  telephone  or 
electronic  mail.  This  was  done  a  number  of  times  for 
several  sites.  The  report  program  was  run  against  the 
accumulated  data  for  a  particular  site  and  the  results 
mailed  back  to  the  site.  If  the  report  v:as  a  summary 
type  report  and  consisted  of  a  few  lines,  the  results 
could  have  been  sent  back  by  electronic  mail.  Because 
there  was  only  one  person  at  Ft.  Detrick  to  provide 
technical  suport  to  all  the  sites  in  addition  to  his 
regular  system  development  duties,  the  amount  of  time 
available  was  limited.  Therefore,  mainframe  access  by 
each  site  was  deemed  necessary. 

Each  site  already  had  dial-up  capability  with 
Crosstalk,  a  modem,  and  an  Optimis  account  for 
electronic  mail  communications.  The  mainframe  computer 
had  to  be  set  up  for  site  access.  This  required  a  FOCUS 
Exec  file  for  each  site.  The  FOCUS  Exec  file  was  a 
storage  area  that  contained  the  FOCUS  report 
procedures.  FOCUS  automatically  accesses  a  user's  Exec 
file  for  the  programs  it  needs.  The  master  file 
descriptions  were  already  available  and  were  shared  by 
each  site.  Other  than  accessing  the  data  which  was 
already  available,  no  other  FOCUS  consideration  was 
necessary. 


Each  site  was  assigned  a  Data  Base  Administrator 
(usually  the  site  operator)  and  a  password  to  the 
mainframe  computer.  Because  the  site  personnel  had  no 
training  or  experience  in  using  mainframe  operating 
systems,  a  CLIST  (command  list)  was  created  to  provide 
direct  access  to  the  FOCUS  system.  The  CLIST  was  a 
group  of  TSO  coitanands  that  allowed  various  tasks  to  be 
executed  under  the  mainframe  operating  system.  This 
CLIST  was  set  up  so  that  when  the  mainframe  computer  was 
accessed  from  a  site,  all  the  FOCUS  files  necessary  for 
that  site  were  allocated,  and  the  operating  system 
placed  the  user  directly  into  the  FOCUS  environment. 

Here  the  user  was  familiar  with  many  of  the  FOCUS 
commando  and  editing  techniques  because  of  the 
similarity  to  the  PC  version  of  FOCUS.  Only  minimal 
assistance  was  needed  to  overcome  some  of  the 
differences  between  the  PC  and  mainframe.  When  the  user 
exited  from  FOCUS,  the  CLIST  regained  control  and  logged 
the  user  off  the  mainframe.  Thus  the  operating  system 
was  transparent  to  the  user.  An  example  of  the  CLIST 
for  Ft.  Polk  follows: 
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PROC  0  DEBUG 

IF  $& DEBUG  =  $DEBUG  THEN  + 

CONTROL  CONLIST  LIST  SYMLIST  MSG 
ELSE  CONTROL  NOMSG 

FREE  F (MASTER  FOCEXEC  ERRORS  USERLIB  HOLD  HOLDMAST  SAVE  FOCSORT) 

FREE  F (REBUILD  FOCSTACK  FOCSML  OFFLINE  DIAGNOS  PROCEDUR  PROVIDER) 

FREE  F( PATIENT  CLINIC  VPOLK  NPOLK  NDIAG  NPROC  OTHER) 

ALLOC  F(HOLD)  SP(300  60)  TRACKS 

ALLOC  F(HOLDMAST)  SP(10  10)  TRACKS  DIR(IO) 

ALLOC  F(SAVE)  SP(300  60)  TRACKS 

ALLOC  F (REBUILD)  SP(500  100)  TRACKS  UNIT(SYSDA) 

ALLOC  F( FOCSORT)  SP(30  10)  TRACKS 
ALLOC  F (FOCSTACK)  SP(20  20)  TRACKS 
ALLOC  F( FOCSML)  SP(100  50)  TRACKS 
ALLOC  F (OFFLINE)  SYSOUT(A) 

ALLOC  F (MASTER)  DA (' PMS . MASTER . DATA ' )  SHR 

ALLOC  F( FOCEXEC)  DA (' &SYSPREF. . FOCEXEC. DATA '  ' PMS . FOCEXEC . DATA ' )  SHR 

ALLOC  F ( DIAGNOS )  DA ( ' PMS . DIAGNOS . FOCUS ' )  SHR 

ALLOC  F ( PROCEDUR)  DA ( ' PMS . PROCEDUR . FOCUS ' )  SHR 

ALLOC  F ( PROVIDER)  DA ( ' PMS . PROVIDER . FOCUS ' )  SHR 

ALLOC  F( PATIENT)  DA (' PMS . PATIENT. FOCUS  * )  SHR 

ALLOC  F (CLINIC)  DA (' PMS . CLINIC. FOCUS ' )  SHR 

ALLOC  F( VPOLK)  DA (' PMS .VPOLK. FOCUS ' )  SHR 

ALLOC  F (NPOLK)  DA ( ' PMS . NPOLK. FOCUS • )  SHR 

ALLOC  F ( NDIAG )  DA ( ' PMS .NDIAG . FOCUS ' )  SHR 

ALLOC  F (NPROC )  DA ( • PMS . NPROC . FOCUS ' )  SHR 

ALLOC  F ( OTHER)  DA ( ' PMS . OTHER . FOCUS ' )  SHR  % 

ALLOC  F( ERRORS)  DA (' SYS2 . FOC503 . ERRORS . DATA ' )  SHR 
ALLOC  F (USERLIB)  DA ( ' SYS2 . FOC503 . FOCLIB. LOAD '  + 
'SYS2.FOC503.FUSELIB.LOAD')  SHR 
CALL  ' S YS 2. FOC5 03. FOCLIB. LOAD (FOCUS) » 

FREE  F (MASTER  FOCEXEC  ERRORS  USERLIB  HOLD  HOLDMAST  SAVE  FOCSORT) 

FREE  F (REBUILD  FOCSTACK  FOCSML  OFFLINE  DIAGNOS  PROCEDUR  PROVIDER) 

FREE  F (PATIENT  CLINIC  VPOLK  NPOLK  NDIAG  NPROC  OTHER) 

LOGOFF 


The  limitation  of  this  application  was  the  printing 
capability  of  the  PCs.  It  was  not  practical  to  transmit 
large  reports  over  telephone  lines  because  of  the  cost 
involved  and  the  possibility  of  errors  during 
transmission.  Also,  the  printers  at  the  sites  were  not 
capable  of  the  speeds  needed  to  efficiently  handle  this 
traffic.  More  expensive  modems  could  have  handled  error 
checking,  and  enhanced  printers  could  have  printed 
faster  allowing  the  transmission  of  reports  back  to  the 
sites.  With  exisiting  equipment,  however,  report 
requests  could  be  written  by  the  site  user  and  executed 
with  the  results  then  printed  at  Ft.  Detrick  and  mailed 
back  to  the  site. 

All  six  sites  were  given  the  capability  to  access 
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the  mainframe  data  although  not  all  of  them  used  it. 
There  were  several  reasons  for  this.  In  some  cases  new 
site  operators  had  all  they  could  handle  learning  the  PC 
systems.  In  some  cases,  the  sites  had  little  foresight 
in  regarding  the  advantages  of  preparing  reports  from 
the  data.  In  all  cases,  the  sites  were  extremely  busy 
scanning  and  running  their  own  reports  so  that  little 
time  could  be  spent  picking  up  an  extra  task  such  as 
accessing  and  developing  additional  FOCUS  procedures  on 
the  mainframe.  Had  the  study  continued  to  the  point 
where  the  development  process  halted,  and  had  the  sites 
had  adeqpjate  personnel  to  run  their  systems,  more 
mainframe  use  would  probably  have  occurred. 

6.4  MAINFRAME  DATA  BASE  DESCRIPTION 

The  mainframe  data  was  different  from  PC  data  in 
several  ways.  The  first  difference  was  size.  PC  data 
was  collected  on  a  monthly  basis.  Reports  and  other 
programs  were  run  on  the  monthly  data  which  in  the 
larger  sites  could  be  four  to  six  million  characters  of 
data  for  the  Visit  file.  The  mainframe  data  was  an 
accumulation  of  all  the  months  for  each  of  the  six  sites 
and  exceeded  186  million  characters  for  the  first  part 
of  the  study.  The  second  difference  was  in  a  design 
change  which  was  implemented  in  the  first  five  months  of 
1987  and  became  effective  May  1987.  Some  old  fields 
were  eliminated,  and  some  new  fields  were  created. 

While  the  old  and  new  data  bases  were  similar,  they  were 
different  enough  to  have  to  be  kept  separate.  Thus 
master  files  and  double  data  files  had  to  be  maintained 
and  kept  available.  The  user  had  to  be  familiar  with 
the  names  of  these  files  and  use  the  proper  files  to 
access  the  portion  of  the  study  being  analyzed. 
Additionally,  since  the  data  from  the  six  sites  were 
combined,  a  method  was  needed  to  identify  where  the  data 
originated.  A  new  field  or  extension  of  some  fields  was 
created  containing  site  identification.  The  last 
difference  had  to  do  with  security  and  confidentiality 
of  the  data.  Because  of  the  confidentiality  of  medical 
dara,  some  fields  were  eliminated  or  encrypted  when 
transferred  to  the  mainframe.  For  instance,  provider 
names  were  deleted  and  Social  Security  numbers  of 
patients  were  encrypted.  FOCUS  master  file  descriptions 
had  to  be  changed  from  PC  versions  to  reflect  these 
Ciianges.  Additionally,  security  functions  were 
performed  on  the  data  at  the  site  level  so  that  when  the 
data  on  portable  disk  cartridges  left  the  site  by  mail 
the  confidentiality  of  the  data  was  preserved. 

The  mainframe  data  was  initially  designed  to  be 
very  sirilar  to  the  PC  data.  Thus  FOCUS  load  and  report 
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procedures  as  well  as  others  could  be  run  on  both 
systems  with  little  modification.  There  were  six  data 
files;  a  Visit  file,  a  Clinic  description  file,  a 
Patient  Registration  file,  a  Provider  Registration  file, 
a  Procedure  description  file  and  a  Diagnosis  description 
file.  After  several  months,  the  Visit  file  became 
unwieldy  to  maintain.  In  addition  some  programs  took  an 
excessive  amount  of  time  to  execute.  The  Visit  file  was 
broken  up  into  six  files,  one  for  each  site.  FOCUS 
could  easily  join  these  files  when  reports  required 
composite  data,  and  programs  ran  more  efficiently.  The 
names  of  the  files  are  given  below: 


PMS.VBAMC. FOCUS 
PMS . VBRAG . FOCUS 
PMS.VCAMP. FOCUS 
PMS. VJACK. FOCUS 
PMS. VPOLK. FOCUS 
PMS . VREDS . FOCUS 
PMS. CLINIC. FOCUS 
PMS .  PATIENT .  FOCUS 
PMS . PROVIDER. FOCUS 
PMS . PROCEDUR. FOCUS 
PMS . DIAGNOS . FOCUS 


Visit  file  for  BAMC 
Visit  file  for  Bragg 
Visit  file  for  Campbell 
Visit  file  for  Jackson 
Visit  file  for  Polk 
Visit  file  for  Redstone 
Clinic  description  file 
Patient  registration  file 
Provider  registration  file 
Procedure  description  file 
Diagnosis  description  file 


The  PMS  preceding  each  file  name  is  a  mainframe 
project  identifier.  PMS  stands  for  Performance 
Measurement  Study. 


After  the  redesign  of  the  forms  in  May  1987,  new 
data  files  were  created  in  some  cases.  The  data  files 
are  generally  referred  to  as  old  data  and  new  data. 

When  analyzing  the  old  data,  the  files  in  the  above  list 
should  be  used.  When  analyzing  the  new  data,  the 
following  files  should  be  used. 


PMS . NBAMC . FOCUS 
PMS . NBRAG . FOCUS 
PMS . NCAMP . FOCUS 
PMS. NJACK. FOCUS 
PMS. NPOLK. FOCUS 
PMS . NREDS . FOCUS 
PMS . CLINIC . FOCUS 
PMS . PATIENT . FOCUS 
PMS . PROVIDER . FOCUS 
PMS. NPROC. FOCUS 
PMS. NDI AG. FOCUS 
PMS. OTHER. FOCUS 


New  Visit  file  for  BAMC 
New  Visit  file  for  Bragg 
New  Visit  file  for  Campbell 
New  Visit  file  for  Jackson 
New  Visit  file  for  Polk 
New  Visit  file  for  Redstone 
Same  as  old  file 
Same  as  old  file 
Same  as  old  file 
New  Procedure  descriptions 
New  Diagnosis  descriptions 
Other  code  descriptions 


Notice  the  new  file  called  OTHER.  This  file  was 
create-^  because  of  special  codes  that  were  neither 
procedures  nor  diagnoses. 
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6.4.1  MAINFRAME  MASTER  FILE  DESCRIPTIONS 

Master  file  descriptions  in  the  FOCUS  format  are 
provided  below  for  the  data  files  listed  in  the  previous 
section.  Since  the  master  file  descriptions  for  the 
visit  file  tor  each  site  are  identical,  only  one  listing 
is  provided. 

The  master  files  are  stored  in  a  PDS  called 
PMS .MASTER. DATA.  Each  master  file  is  a  member  in  the 
PDS.  The  member  names  correspond  to  the  portion  of  the 
data  file  names  between  the  periods.  Thus  the  master 
file  corresponding  to  PMS. VBAMC. FOCUS  is  written 
PMS. MASTER. DATA { VBAMC ) .  A  member  name  follows  the  PDS 
file  name  in  parentheses. 

6. 4. 1.1  OLD  VISIT  MASTER  FILE 


FILENAME=VBAMC, SUFFIX=FOC, $ 

SEGNAME=SITE_ID, SEGTYPE=S1, $ 

FIELDNAME=SITE,  ALIAS=SID,  F0RMAT=A4 , $ 

SEGNAME=VISLOC, PARENT=SITE_ID, SEGTYPE=S1 , $ 

FIELDNAME=CLINIC,  ALIAS=CL_UCA,  F0RMAT=A4 , $ 

SEGNAME=VISDTE , PARENT=VISLOC , SEGTYPE=S 1 , $ 

FIELDNAME=VISIT_DATE,  ALIAS=VDATE,  F0RMAT=I6YMD, $ 

SEGNAME=VISPROV, PARENT=VISDTE, SEGTYPE=S1 , $ 

FIELDNAME=PROV_ID,  ALIAS=PR0V1,  F0RMAT=A5,$ 

SEGNAME= VISITOR, PARENT=VISPROV, SEGTYPE=S1 , $ 

FIELDNAME=PATIENT_ID,  ALIAS=PTID,  F0RMAT=A8 , $ 


SEGNAME=LITHO , PARENT=VISITOR, SEGTYPE=S1 , $ 

FIELDNAME=LITHO_CODE ,  ALIAS=LITHO ,  F0RMAT=I8 , $ 
FIELDNAME=FORM_NUM,  ALIAS=FNUM,  F0RMAT=A2 , $ 


SEGNAME=V_DATA , PARENT=LITHO , SEGTYPE=U , $ 
FIELDNAME=VISIT_REASON,ALIAS=VISRES, 
FIELDNAME=PR0V1_TIME ,  ALIAS=TIME1 , 
FIELDNAME=PR0VIDER_2 ,  ALIAS=PR0V2 , 
FIELDNAME=PR0V2_TIME,  ALIAS=TIME2 , 
FIELDNAME=PR0V2_RES0N ,  ALIAS=PR0V2RES , 
FIELDNAME=PR0V1_SEEN ,  ALIAS=PR0V1SEEN , 
FIELDNAME=PR0V1_SAME , 
FIELDNAME=PR0V2_SEEN, 
FIELDNAME=PR0V2_SAME , 

FIELDNAME=LAST_12 , 

FIELDNAME=NEW_PROBLEM,  ALIAS=NEWPR0B, 
FIELDNAME=APPT_STATUS ,  ALIAS=APPSTAT , 


ALIAS=PR0V1SAME , 
ALIAS=PR0V2SEEN , 
ALIAS=PR0V2SAME , 
ALIAS=LAST12 , 


FORMAT 

FORMAT 

FORMAT 

FORMAT 

FORMAT 

FORMAT 

FORMAT 

FORMAT 

FORMAT 

FORMAT 

FORMAT 

FORMAT 


=A1,$ 
=13,  $ 
=A5,$ 
=13,  $ 
=A1,$ 
=A1,$ 
=A1,$ 
=A1,$ 
=A1,$ 
=A1,$ 
=A1,$ 
=A1,$ 


I 
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FIELDNAME=INP_REFERAL,  ALIAS=REFERAL,  F0RMAT=A1,$ 
FIELDNAME=PLACE_OF_VIS , ALIAS=PLACE ,  F0RMAT=A1 , $ 
FIELDNAME=JOB_RELATED,  ALIAS=JOBREL ,  F0RMAT=A1,$ 
FIELDNAME=DISPOSITION,  ALIAS=DISPO,  F0RMAT=A1,$ 
FIELDNAME=LAB_ORDER,  ALIAS=LAB,  F0RMAT=A1,$ 

FIELDNAME=PRESCRIPTION , ALIAS=RX ,  F0RMAT=A1 , $ 

FIELDNAME=PURP_VISIT,  ALIAS=PRPVST ,  F0RMAT=A1,$ 
FIELDNAME=JOB_REL_SURV , ALIAS=RELSURV ,  F0RMAT=A1 , $ 
FIELDNAME=ADMIN_REAS ,  ALIAS=ADMREAS ,  F0RMAT=A1 , $ 
FIELDNAME=DIAG1_RULE ,  ALIAS=DX1RULE ,  F0RMAT=A1 , $ 
FIELDNAME=DIAG1_C0DE,  ALIAS=DX1C0DE ,  F0RMAT=A5,$ 

SEGNAME=V_DIAG2 , PARENT=LITHO, SEGTyPE=Sl , $ 

FIELDNAME=DIAG2_C0DE,  ALIAS=DX2C0DE,  F0RMAT=A5 , $ 
FIELDNAME=DIAG2_RULE,  ALIAS=DX2RULE ,  FORMAT=Al,$ 

SEGNAME=V_PROC, PARENT=LITHO, SEGTYPE=S1 , $ 

FIELDNAME=PROC_CODE,  ALIAS=PCODE,  F0RMAT=A5,$ 

SEGNAME=M_CODE , PARENT=LITHO , SEGTYPE=S1 , $ 

FIELDNAME=M_CODE,  ALIAS=MCODE,  F0RMAT=A6,$ 

FIELDNAME=M_DESCR ,  ALIAS=MDESCR ,  F0RMAT=A3  2 , $ 

SEGNAME=V_SUPPL, PARENT=LITHO, SEGTYPE=S1 , $ 

FIELDNAME=SUPPL_DISP,  ALIAS=SUPPDISP,  F0RMAT=A1,$ 

SEGNAME=V_XRAY , PARENT=LITHO , SEGTYPE=S 1 , $ 

FIELDNAME=X_RAY ,  ALIAS=XRAY,  F0RMAT=A1,$ 

SEGNAME=V_OTHER, PARENT=LITHO, SEGTYPE=S1 , $ 

FIELDNAME=OTHER_ORDER,  ALI AS=OTHORD ,  F0RMAT=A1,$ 

SEGNAME=V_SPEC, PARENT=LITH0,SEGTYPE=S1, $ 

FIELDNAME=SPECIAL_PROG , ALIAS=SPROG ,  F0RMAT=A2 , $ 

SEGNAME=V_PSY , PARENT=LITHO , SEGTYPE=S1 , $ 

FIELDNAME=ASSESMNT ,  ALIAS=ASSESMNT ,  FORMAT=A2 , $ 

END 

DBA=XYZQQ,$ 

The  last  line  of  the  master  file  is  the  Data  Base 
Administrator  information.  In  this  case  the  file  is 
protected  by  a  password  given  by  XYZQQ  (not  the  real 
password) . 

Notice  the  PATIENT_ID  field  has  eight  characters. 
The  PC  master  file  has  11  characters.  Normally  the 
patient  identification  is  the  Social  Security  number 
(nine  digits)  followed  by  the  family  member  prefix  (FMP) 
(two  digits) .  However,  on  the  mainframe  the  Social 
Security  number  is  encrypted.  The  encryption  algorithm 
reduces  the  nine  digit  number  to  a  six  character  code. 
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Thus  the  encrypted  Social  Security  number  followed  by 
the  FMP  results  in  eight  characters. 

6. 4. 1.2  CLINIC  MASTER  FILE 


FILENAME=CLINIC, SUFFIX=FOC, $ 

SEGNAME=CLINIC , SEGTYPE=S1 , $ 

FIELDNAME=CLINIC, ALIAS=CLUCA, F0RMAT=A8 , FIELDTYPE=I , $ 
FIELDNAME=CL_TITLE,  ALIAS=302TITLE ,  FORMAT=A20,$ 
FIELDNAME=CL_302CODE,  ALIAS=302CLCODE,  F0RMAT=A2  ,$ 
FIELDNAME=CL_302LINE,  ALIAS=302CLLINE ,  F0RMAT=I3  ,$ 
END 

DBA=XYZQQ,$ 

A  brief  explanation  of  this  master  file  is 
necessary.  First  notice  the  format  of  the  CLINIC 
field.  It  is  eight  characters  in  length.  This  is 
because  the  site  identification  code,  a  four-digit 
number  is  included  as  the  first  part  of  the  UCA  code. 
Thus  for  BAMC  which  has  a  site  code  of  0109,  a  UCA  code 
of  BALA  would  look  like  0109BALA.  Secondly,  the  third 
and  fourth  field  names,  CL_302CODE  and  CL_302LINE  were 
designed  at  the  beginning  of  the  study  but  were  never 
used.  Thus  these  latter  fields  contain  no  data. 

6. 4. 1.3  PATIENT  MASTER  FILE 


FILENAME=PATIENT, SUFFIX=FOC, $ 


SEGNAME=PTSEG, 
FIELDNAME=PATIENT 
FIELDNAME=PT 
FIELDNAME=PT 
FIELDNAME=PT 
FIELDNAME=PT 
FIELDNAME=PT 
FIELDNAME=PT 
FIELDNAME=PT 
FIELDNAME=PT 
FIELDNAME=PT 
FIELDNAME=PT 
FIELDNAME=PT 
FIELDNAME=PT 
FIELDNAME=PT 
FIELDNAME=PT 
FIELDNAME=PT 
FIELDNAME=PT 
END 

DBA=XYZQQ, $ 


SEGTYPE=S1,$ 

_ID, ALIAS=PTID, F0RMAT=A12 , 
_D0B,  ALIAS=PATDOB, 

_CATEG0RY , ALIAS=CATEG , 
_LITH0,  ALIAS=PTLITHO, 
_REGDATE,  ALIAS=REGDATE , 
_GENDER,  ALIAS=SEX, 

_RACE ,  ALIAS=RACE , 

_PREFIX,  ALIAS=PREFIX, 
_PAY_GRADE , ALIAS=PAYGRADE , 
J0B_C0DE , ALIAS=J0BC0DE , 
LOCATION , ALIAS=PTLOC , 
_TRN_TDY,  ALIAS=TRAINEE , 
_VAELIG ,  ALIAS=VA , 

_HCI ,  ALIAS=HCI , 

_Z IP_C0DE , ALI AS=Z IP , 
_DUAL_SSN , ALIAS=PTDUALSSN , 
FOREIGN,  ALIAS=PTFORGN , 


FIELDTYPE=I,$ 
F0RMAT=I6YMD, $ 
F0RMAT=A3  ,$ 
F0RMAT=A8  ,$ 
F0RMAT=I6YMD,$ 
F0RMAT=A1  ,$ 
F0RMAT=A1  ,$ 
FORMAT=A2  ,$ 
F0RMAT=A2  ,$ 
F0RMAT=A4  ,$ 
F0RMAT=A6  ,$ 
F0RMAT=A1  ,$ 
F0RMAT=A1  ,$ 
F0RMAT=A1  ,$ 
FORMAT=A5  ,$ 
F0RMAT=A6  ,$ 
F0RMAT=A3  ,$ 


The  PATIENT  ID  field  has  12  characters  in  it. 


The 
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field  contains  a  four-digit  site  identification  code 
followed  by  the  same  eight  characters  in  the  visit 
master  file  called  PATIENT_ID. 

6. 4. 1.4  PROVIDER  MASTER  FILE 
FILENAME=PROVIDER, SUFFIX=FOC, $ 

SEGNAME= PROVIDER, SEGTYPE=S1 , $ 

FIELDNAME=PROV_ID, ALIAS=PROVID, FORMAT=A9 , FIELDTYPE=I , $ 
FIELDNAME=PROV_DATE ,  ALI AS=PROVDATE ,  FORMAT=I 6 YMD , $ 
FIELDNAME=PROV_STAT,  ALIAS=PRSTAT,  F0RMAT=A1  ,$ 

FIELDNAME=PROV_CATEG,  ALIAS=PRCATEG ,  F0RMAT=A2  ,$ 

FIELDNAME=PROV_PRPOS,  ALIAS^PRPOS,  F0RMAT=A2  ,$ 

FIELDNAME=PROV_PAYGR,  ALIAS=PRPAYGR,  FCPJ1AT=A2  ,$ 

FIELDNAME=PROV_JOBCODE, ALIAS=PRJCODE,  FORMAT=A7  ,$ 
FIELDNAME=PROV_LITHO,  ALIAS=PRLTH,  FORMAT=A8  ,$ 

END 

DBA=XYZQQ,$ 

The  PROV_ID  field,  normally  the  first  letter  of  the 
last  name  followed  by  the  last  four  digits  of  the 
provider's  Social  Security  number,  is  preceded  by  the 
four-digit  site  identification  number  bringing  the 
format  length  to  nine  characters. 

6. 4. 1.5  PROCEDURE  MASTER  FILE 
FILENAME=PROCEDUR, SUFFIX=FOC, $ 

SEGNAME=PROCEDUR, SEGTYPE=S1 , $ 

FIELDNAME=PROC_CODE , ALIAS=PRCCD, FORMAT=A5 , FIELDTYPE=I , $ 
FIELDNAME=PROC_DESCR,  ALIAS=PRCDSC,  FORMAT=A67 , $ 

END 

DBA=XYZQQ,$ 

Except  for  the  file  name,  the  old  and  new  procedure 
master  files  are  identical. 

6.4. 1.6  DIAGNOSIS  MASTER  FILE 
FILENAME=DIAGNOS , SUFFIX=FOC, $ 

SEGNAME=DI AGNOS , SEGTYPE=S 1 , $ 

FIELDNAME=DIAG_CODE , ALIAS=DGNCD, FORMAT=A5 , FIELDTYPE=I , $ 
FIELDNAME=DIAG_DESCR,  ALI AS=DGNDSC ,  FORMAT=A50,$ 

END 

DBA=XYZQQ,$ 

Except  for  the  file  name,  the  old  and  new  diagnoses 
master  files  are  identical. 


6.4. 1.7  NEW  VISIT  MASTER  FILE 


FILENAME=NBAMC , SUFFIX=FOC , $ 

SEGNAME=SITE_ID, SEGTyPE=Sl , $ 

FIELDNAME=SITE,  ALIAS=SID,  F0RMAT=A4 , $ 

SEGNAME=VISLOC, PARENT=SITE_ID, SEGTYPE=S1 , $ 

FIELDNAME=CLINIC,  ALIAS=CL_UCA ,  F0RMAT=A4 , $ 

SEGNAME=VISDTE , PARENT=VISLOC , SEGTYPE=S 1 , $ 

FIELDNAME=VISIT_DATE,  ALIAS=VDATE,  F0RMAT=I6YMD, $ 

SEGNAME=VISPROV , PARENT=VISDTE , SEGTYPE=S 1 , $ 

FIELDNAME=PROV_ID ,  ALIAS=PR0V1 ,  FORI-IAT=A5 ,  $ 


SEGNAME=VISITOR, PARENT=VISPROV, SEGTYPE=S1 , $ 

FIELDNAME=PATIENT_ID,  ALIAS=PTID,  F0RMAT=A8 , $ 


ALIAS=FNUM, 
ALIAS=VCNT, 
ALIAS=TIME1, 
ALIAS=PR0V2 , 
ALIAS=TIME2  , 


SEGNAME=LITHO, PARENT=VISITOR, SEGTYPE=S1 , 
FIELDNAME=LITHO_CODE ,  ALIAS=LITHO , 
FIELDNAME=FORM_NUM , 

FIELDNAME=VISIT_CNT , 
FIELDNAME=PR0V1_TIME , 
FIELDNAME=PR0VIDER_2 , 
FIELDNAME=PR0V2_TIME , 
FIELDNAME=PR0V2_RES0N ,  ALIAS=PR0V2RES , 
FIELDNAME=APPT_STATUS ,  ALIAS=APPSTAT , 
FIELDNAME=PLACE_OF_VIS , ALIAS=PLACE , 
FIELDNAME=INP_REFERAL,  ALIAS=REFERAL, 
FIELDNAME=JOB_RELATED,  ALIAS=JOBREL, 
FIELDNAME=MIL_DUTY , 

F I E  LDN AME=MI L_QTR , 

F1ELDNAME=MIL_PR0F, 

FIELDNAME=NOT_AVAI L , 
FIELDNAME=ADMITTED, 

FIELDNAME=INFIELD , 

FIELDNAME=INJURIES , 

FIELDNAME=PURP_VIS , 

FIELDNAME=RO_F_UP , 
FIELDNAME=DIAG1_C0DE, 


ALIAS=DUTY , 
ALIAS=QTR, 
ALIAS=PROF, 
ALIAS=NAVAIL, 
ALIAS=ADMIT, 
ALIAS=ILLN, 
ALIAS=INJ , 
ALIAS=PURP, 
ALIAS=RULE , 
ALIAS=DX1C0DE, 


F0RMAT=I8,$ 
F0RMAT=A2 ,  $ 
F0RMAT=I1, $ 
F0RMAT=I3,$ 
F0RMAT=A5 , $ 
F0RMAT=I3,$ 
F0RMAT=A1 , $ 
F0RMAT=A1 , $ 
F0RMAT=A1 , $ 
F0RMAT=A4 , $ 
F0RMAT=A1, $ 
F0RMAT=A1 , $ 
F0RMAT=A1 , $ 
F0RMAT=A1, $ 
F0RMAT=A1 , $ 
F0RMAT=A1 , $ 
F0RMAT=A1 , $ 
F0RMAT=A1 , $ 
F0RMAT=A1 , $ 
F0RMAT=A1 ,  $ 
F0RMAT=A5 , $ 


SEGNAME=V_PROC, PARENT=LITHO, SEGTYPE=S1 , $ 

FIELDNAME=PROC_CODE,  ALIAS=PCODE,  F0RMAT=A5,$ 

FIELDNAME=PROV_CD ,  ALIAS=PRCODE ,  FORMAT=Al , $ 

SEGNAME=V_SPCC, PARENT=LITHO,SEGTYPE=Sl , $ 

FIELDNAME=SP_PRE_CODE,  ALIAS=SPCC,  F0RMAT=A1,$ 

SEGNAME=V_OTHER, PARENT=LITHO, SEGTYPE=S1 , $ 

FIELDNAME=OTHER_CODE,  ALIAS=OTHER,  F0RMAT=A5,$ 
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SEGNAME=V_GROUP , PARENT=LITHO , SEGT YPE=S 1 , $ 

FIELDNAME=UNIT_ID,  ALIAS=UIC,  F0RMAT=A6,$ 

FIELDNAME=TIME_PR1 ,  ALI AS=TIMPR1 ,  FORMAT=I 3 , $ 

FIELDNAME=TIME_PR2 ,  ALIAS=TIMPR2 ,  FORMAT=I3,$ 

FIELDNAME=TIME_TR1 ,  ALIAS=TIMTR1 ,  FORMAT=I 3 , $ 

FIELDNAME=TIME_TR2 ,  ALIAS=TIMTR2 ,  FORMAT=I 3 , $ 

FIELDNAME=NO_ACT_DUTY ,  ALIAS=MACT ,  F0RMAT=I3 , $ 

FIELDNAME=NO_OTH_DUTY,  ALIAS=OACT,  F0RMAT=I3,$ 

FIELDNAME=NO_RET_MIL,  ALIAS=RMIL,  F0RMAT=I3,$ 

FIELDNAME=NO_DEPEND,  ALIAS=DEPD,  F0RMAT=I3,$ 

FIELDNAME=NO_CIVIL,  ALIAS=CIVIL,  F0RMAT=I3,$ 

FIELDNAME=CONT_SHEET  ALIAS=CSHEET ,  F0RMAT=A1,$ 

SEGNAME=V_SPEC , PARENT=LITHO, SEGTYPE=S1 , $ 

FIELDNAME=SPEC_PROG,  ALIAS=SPROG,  F0RMAT=A1,$ 

SEGNAME=V_DIAG2 , PARENT=LITHO , SEGTYPE=S 1 , $ 

FIELDNAME=DIAG2_C0DE ,  ALIAS=DX2C0DE ,  F0RMAT=A5 , $ 

SEGNAME=V_PS Y , PARENT=LITHO , SEGTYPE=S 1 , $ 

FIELDNAME=ASSESMNT,  ALIAS=ASSESMNT,  F0RMAT=A1,$ 

SEGNAME=V_DISPOS , PARENT=LITHO, SEGTYPE=S1 , $ 

FIELDNAME=DISPOS,  ALIAS=DISP,  F0RMAT=A2 , $ 

SEGNAME=V_GRSSN , PARENT=LITHO, SEGTYPE=S1 , $ 

FIELDNAME=GR_PAT_ID,  ALIAS=GPATID,  F0RMAT=A11,$ 

END 

DBA=XYZQQ,$ 

6. 4. 1.8  OTHER  CODE  MASTER  FILE 
FILENAME=OTHER, SUFFIX=FOC, $ 

SEGNAME=OTHER, SEGTYPE=S1 , $ 

FIELDNAME=OTHER_CODE, ALIAS=OTHC, FORMAT=A5 , FIELDTYPE=I , $ 
FIELDNAME=OTHER_DESCR, ALIAS=OTHDSC,  FORMAT=A67 , $ 

END 

DBA=XYZQQ,$ 

6.4.2  FIELD  DESCRIPTIONS 

Except  for  cases  mentioned  in  the  master  file 
section,  the  field  descriptions  are  the  same  as  in  the 
PC  version.  See  the  PC  section  (4.7)  for  field  sizes 
and  contents. 

6.4.3  PICTURE  OF  DATA  BASE 

All  the  data  files  except  visit  data  are  single 
segment.  In  other  words,  the  hierarchical  structure  is 
one  level  although  there  are  multiple  instances  of 


segments.  The  visit  data  base  has  several  levels  and  a 
picture  of  the  data  base  helps  in  understanding  the 
structure.  The  PC  version  which  is  shown  elsewhere  in 
the  manual  is  identical  except  for  the  top  segment  which 
contains  the  site  identification. 

A  mainframe  picture  is  shown  here  for 
completeness.  There  are  two  versions,  however,  one  for 
the  old  data  and  one  for  the  new  data  after  the  forms 
redesign  of  May  1987. 
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PICTURE  DESCRIPTION  OF  NEW  VISIT  DATA  BASE 


i 
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6.4.4  ENCRYPTION  OF  THE  SSN 

Encryption  of  the  Social  Security  number  has  been 
discussed  previously.  Confidentiality  of  medical  data 
requires  that  unauthorized  personnel  not  have  access  to 
data  and  that  the  medical  information  not  be  traced  to 
the  patient.  The  current  data  base  is  protected  in  two 
ways.  The  data  is  password  protected  and  identifying 
information  such  as  the  Social  Security  number  is 
encrypted.  The  encryption  took  place  at  the  site  before 
the  data  left  the  hospital.  Thus  had  any  disk  cartridge 
fallen  into  the  wrong  hands,  the  data  was  protected. 

An  explicit  description  of  the  encryption  algorithm 
is  not  given  here  because  confidentiality  of  the  data 
base  currently  residing  on  the  mainframe  computer  at  Ft. 

Detrick  is  required.  The  algorithm  does,  however,  use  a 
32-base  number  system  which  serves  two  useful  purposes. 

First,  for  every  Social  Security  number  there  is  a 

unique  encryption.  This  is  necessary  since  the 

patient's  visit  data  must  be  joined  or  connected  to  the 

patient's  registration  data  which  is  a  one-to-one 

correspondence.  Further,  if  the  same  patient  is  seen 

more  than  once,  the  encrypted  Social  Security  numbers 

must  be  able  to  identify  these  cases.  Secondly,  using  a 

32-based  number  system  allows  transforming  a  nine  digit 

number  into  a  six  character  field.  Thus  three  % 

characters  are  saved  for  every  patient  visit  and  every 

patient  registered  in  the  data  base. 
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SCAN790.FIL 
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SCAN830.FIL 

SCAN840.FIL 

SCAN850.FIL 

SCAN860.FIL 

SCAN900.FIL 
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Aud i o 1 ogy/ Speech 

Cardiology 

Cardiothoracic 

Dermatology 

Endocrine 

ENT 

Family  Practice 

Gastroenterol ogy 

General  Surgery 

Gynecology 

Infectious  Diseases 

Internal  Medicine 

Nephrology/Dialysis 

Neurology 

Neurosurgery 

Nutrition 

OB 

Oncol ogy/ Hemato 1 ogy 

Ophthamology 

Optometry 

Ortho  Appliance/Cast 
Orthopedics 
Occupational  Therapy 
Pain/Physical  Medicine 
Pediatrics 
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Preventive  Medicine 
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Psychology 
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Rheumatology 
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SCAN910.FIL  Occupational  Therapy  Repeat 
SCAN920.FIL  Physical  Therapy  Repeat 
SCAN930.FIL  Repeat 
SCAN940.FIL  Short 
SCAN950.FIL  Social  Work  Short 


400  ADOLESCENT  MEDICINE 


SCAN400.FIL 


H02830247NY0051ADOLESCENT  MEDICINE 
H0343 
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LITHO 
UCA  PFX 
UCA  CODE  1 
UCA  CODE  2 
OTHER  UCA  1 
OTHER  UCA  2 
DATE  (MO) 
DATE  (DY)1 
DATE  (DY)2 
PROVl  PFXl 
PROVl  PFX2 
PROVl  CODE 
SSN 
FMP 

VISIT  COUNT 


PROVl  TIME 
PROV2  PFXl 
PROV2  PFX2 
PROV2  CODE 
PROV2  TIME 
BREASON  FOR  #2 
BREASON  FOR  #2 
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(1) 
(2) 

IF  NOT  SCHED 
BIF  NOT  CLINIC  (1) 
BIF  NOT  CLINIC  (2) 


* 
* 

739160104040011  H0024080001 
2090900706202024V0005010002 
0080800716001024V0012010003 
0070601714501024V0054020004 
217170081800109  V0002000005 
2121200818001024V0002010006 
2434300574601014V0012020007 
14 545005552 01014V0004010008 
1444400554601014V0010010009 
044440033200109  V0014000010 
0434300322001014V0013010011 
1423901332401014V0040040012 
13 32501554 601014V0090090013 
1373601554601014V0020020014 
2141400544601024V0009010015 
2373700351401014V0022020016 
029290033200109  V0014000017 
0282800322001024V0013010018 
1272401332401024V0040040019 
2313100351401024V0022020020 
230300011090109  V0003000021 
2272501080800024H0003 010022 
2171700717001024V0002010023 
217170063610109  V0003000024 
2141201606000024H0003010025 


B 

REF  CODE  PFX 

2040400706002024V0006010026 

B 

REF  CODE  1 

0030300716001024V0012010027 

B 

REF  CODE  2 

0020101714501024V0054020028 

F 

JOB  RELATED 

801 

010029 

F 

MIL  ONLY  DUTY 

801 

010030 

F 

MIL  ONLY  QTRS 

801 

010031 

F 

MIL  ONLY  PROF 

801 

010032 

F 

FILLER 

805 

050033 

B 

SPEC  PRE  CLIN 

306060022140111 

H0009090034 

B 

NOT  AVAILABLE 

320200009070111 

H0003030035 

BPROV2  ADDLl  (YES) 

208080006060011 

V0001010036 

B 

ADDL  PROCl 

1110701071601024V0050050037 

BPROV2  ADDL2  (YES) 

202020006060011 

V0001010038 

B 

ADDL  PROC2 

1050101071601024V0050050039 

B 

ADMITTED 

211110019190011 

V0001010040 

BUNL  REAS  PRIM  PFX 
B  UNL  REAS  PRIM 
B  UNL  REAS  SEC  PFX 
B  UNL  REAS  SEC 

B  FOLLOW/R  OUT 

B  PROC  PROVl  (A) 

B  PROC  PROVl  (B) 

B  PROC  PROVl  (C) 

B  PROC  PROVl  (D) 

B  PROC  PROVl  (E) 

B  PROC  PROV2  (A) 


2121200747602024V0002010041 
1110701748301034V0050050042 
2060600747602024V0002010043 
1050101748 301034V0050050044 
2383800272601024V0002010045 
347470008090111  H0002020046 
347470011160111  H0006060047 
335350008110111  H0004040048 
323230008090111  H0002020049 
323230011240111  H0014140050 
346460008090111  H000202no51 


-1- 


B  PROC  PROV2  (B)  346460011160111  H0006060052 
B  PROC  PROV2  (C)  334340008110111  H0004040053 
B  PROC  PROV2  (D)  322220008090111  H0002020054 
B  PROC  PROV2  (E)  322220011240111  H0014140055 
B  DXl  COLl  (A)  247470031460109  V0016000056 
B  DXl  COLl  (B)  247470048500109  V0003000057 
B  DXl  COLl  (C)  247470052530109  V0002000058 
B  DXl  COLl  (D)  247470056600109  V0005000059 
B  DXl  COLl  (E)  2474700637001024V0008020060 
B  DXl  COL2  (A)  235350029400109  V0012000061 
B  DXl  COL2  (B)  235350043460109  V0004000062 
B  DXl  COL2  (C)  235350049550109  V0007000063 
B  DXl  COL2  (D)  235350057660109  V0010000064 
B  DXl  COL2  (E)  2353500687001024V0003020065 
B  DXl  COL3  (A)  223230029290009  V0001000066 
B  DXl  COL3  (B)  223230031330109  V0003000067 
B  DXl  COL3  (C)  223230036390109  V0004000068 
B  DXl  COL3  (D)  223230042470109  V0006000069 
B  DXl  COLl  (E)  223230050500009  V0001000070 
B  DXl  COLl  (F)  223230053540109  V0002000071 
B  DXl  COLl  (G)  223230056570109  V0002000072 
B  DXl  COLl  (H)  2232300596901024V0011020073 
B  DXl  COL4  (A)  211110029350109  V0007000074 
B  DXl  COL4  (B)  211110038420109  V0005000075 
B  DXl  COL4  (C)  211110044470109  V0004000076 
B  DXl  COL4  (D)  211110049520109  V0004000077 
B  DXl  COL4  (E)  211110055560109  V0002000078 
B  DXl  COL4  (F)  2111100585901024V0002020079 
B  DX2  (A)  346460031460111  H0016160080 
B  DX2  (B)  346460048500111  H0003030081 
B  DX2  (C)  346460052530111  H0002020082 
B  DX2  (D)  346460056600111  H0005050083 
B  DX2  (E)  346460063700111  H0008080084 
B  DX2  (F)  334340029400111  H0012120085 
B  DX2  (G)  334340043460111  H0004040086 
B  DX2  (H)  334340049540111  H0006060087 
B  DX2  (I)  334340057660111  H0010100088 
B  DX2  (J)  334340068700111  H0003030089 
B  DX2  (K)  322220029290011  H0001010090 
B  DX2  (L)  322220031330111  H0003030091 
B  DX2  (M)  322220036390111  H0004040092 
B  DX2  (N)  322220042470111  H0006060093 
B  DX2  (O)  322220050500011  H0001010094 
B  DX2  (P)  322220053540111  H0002020095 
B  DX2  (Q)  322220056570111  H0002020096 
B  DX2  (R)  322220059690111  H0011110097 
B  DX2  (S)  310100029350111  H0007070098 
B  DX2  (T)  310100038420111  H0005050099 
B  DX2  (U)  310100044470111  H0004040100 
B  DX2  (V)  310100049520111  H0004040101 
B  DX2  (W)  310100055560111  H0002020102 
//EOF0520 


410  ALLERGY 


SCAN410.FIL 


H03830247NY0051ALLERGY  * 
H010238  * 
B  LITHO  739160104040011  H0024080001 
B  UCA  PFX  2090900706202024V0005010002 
B  UCA  CODE  1  0080800716001024V0012010003 
B  UCA  CODE  2  0070601714501024V0054020004 
F  OTHER  UCA  801  010005 
B  DATE  (MO)  2434300574601014V0012020006 
B  DATE  (DY)1  1454500555201014V0004010007 
B  DATE  (DY)2  1444400554601014V0010010008 
B  PROVl  PFXl  044440033200109  V0014000009 
B  PROVl  PFX2  0434300322001014V0013010010 
B  PROVl  CODE  1423901332401014V0040040011 
B  SSN  1332501654601014V0090090012 
B  FMP  1373601554601014V0020020013 
B  VISIT  COUNT  2141400544601024V0009010014 
B  PROVl  TIME  2373700351401014V0022020015 
B  PROV2  PFXl  029290033200109  V0014000016 
B  PROV2  PFX2  0282800322001024V0013010017 
B  PROV2  CODE  1272401332401024V0040040018 
B  PROV2  TIME  2313100351401024V0022020019 
BREASON  FOR  #2  (1)  230300011090109  V0003000020 
BREASON  FOR  #2  (2)  2272501080800024H0003010021 
B  IF  NOT  SCHED  2171700717001024V0002010022 
BIF  NOT  CLINIC  (1)  217170063610109  V0003000023 
BIF  NOT  CLINIC  (2)  2141201606000024H0003010024 
B  REF  CODE  PFX  2040400706002024V0006010025 
B  REF  CODE  1  0030300716001024V0012010026 
B  REF  CODE  2  0020101714501024V0054020027 
B  JOB  RELATED  217170032320011  V0001010028 
B  MIL  ONLY  DUTY  2202000241410024V0002010029 
B  MIL  ONLY  QTRS  2191900222001024V0003010030 
B  MIL  ONLY  PROF  2191900181501024V0004010031 
F  FILLER  805  050032 
B  SPEC  PRE  CLIN  306060022140111  H0009090033 
B  NOT  AVAILABLE  320200009070111  H0003030034 
BPROV2  ADDLl  (YES)  208080006060011  V0001010035 
B  ADDL  PROCl  1110701071601024V0050050036 
BPROV2  ADDL2  (YES)  202020006060011  V0001010037 
B  ADDL  PROC2  1050101071601024V0050050038 
B  ADMITTED  223230029290011  V0001010039 
BUNL  REAS  PRIM  PFX  2121200747602024V0002010040 
B  UNL  REAS  PRIM  1110701748301034V005005004 1 
B  UNL  REAS  SEC  PFX  2060600747602024V0002010042 
B  UNL  REAS  SEC  1050101748301034V0050050043 
B  FOLLOW/R  OUT  2383800383701024V0002010044 


B 

PROC 

PROVl 

(A) 

347470008100111 

H0003030045 

B 

PROC 

PROVl 

(B) 

347470012130111 

H0002020046 

B 

PROC 

PROVl 

(C) 

347470016160011 

H0001010047 

B 

PROC 

PROVl 

(D) 

347470019210111 

H0003030048 

B 

PROC 

PROVl 

(E) 

347470025250011 

H0001010049 

B 

PROC 

PROV3 

(F) 

347470027310111 

H0005050050 

B 

PROC 

PROVl 

(G) 

347470033330011 

H0001010051 

-3- 


B  PROC  PROVl  (H)  335350009100111  H0002020052 
B  PROC  PROVl  (I)  335350012120011  H0001010053 
B  PROC  PROVl  (J)  335350014150111  H0002020054 
B  PROC  PROVl  (K)  335350017190111  H0003030055 
B  PROC  PROVl  (L)  335350021210011  H0001010056 
B  PROC  PROVl  CM)  335350024260111  H0003030057 
B  PROC  PROVl  (N)  323230008160111  H0009090058 
B  PROC  PROVl  (O)  323230019190011  H0001010059 
B  PROC  PROVl  (P)  323230021210011  H0001010060 
B  PROC  PROVl  (Q)  323230023250111  H0003030061 
B  PROC  PROVl  (R)  323230027270011  H0001010062 
B  PROC  PROV2  (A)  346460008100111  H0003030063 
B  PROC  PROV2  (B)  346460012130111  H0002020064 
B  PROC  PROV2  (C)  346460016160011  H0001010065 
B  PROC  PROV2  (D)  346460019210111  H0003030066 
B  PROC  PROV2  (E)  346460025250011  H0001010067 
B  PROC  PROV2  (F)  346460027310111  H0005050068 
B  PROC  PROV2  (G)  346460033330011  H0001010069 
B  PROC  PROV2  (H)  334340009100111  H0002020070 
B  PROC  PROV2  (I)  334340012120011  H0001010071 
B  PROC  PROV2  (J)  334340014150111  H0002020072 
B  PROC  PROV2  (K)  334340017190111  H0003030073 
B  PROC  PROV2  (L)  334340021210011  H0001010074 
B  PROC  PROV2  (M)  334340024260111  H0003030075 
B  PROC  PROV2  (N)  322220008160111  H0009090076 
B  PROC  PROV2  (0)  322220019190011  H0001010077 
B  PROC  PROV2  (P)  322220021210011  H0001010078 
B  PROC  PROV2  (Q)  322220023250111  H0003030079 
B  PROC  PROV2  (R)  322220027270011  H0001010080 
B  DXl  COLl  (A)  247470041410009  V0001000081 
B  DXl  COLl  (B)  247470043430009  V0001000082 
B  DXl  COLl  (C)  2474700476101024V0015020083 
B  DXl  COL2  (A)  235350041410009  V0001000084 
B  DXl  COL2  (B)  235350043430009  V0001000085 
B  DXl  COL2  (C)  235350045460109  V0002000086 
B  DXl  COL2  (D)  235350048600109  V0013000087 
B  DXl  COL2  (E)  2353500626301024V0002020088 
B  DXl  COLl  (A)  223230040400009  V0001000089 
B  DXl  COLl  (B)  223230042490109  V0008000090 
B  DXl  COL3  (C)  223230053590109  V0007000091 
B  DXl  COL3  (D)  223230061680109  V0008000092 
B  DXl  COLl  (E)  211110040420109  V0003000093 
B  DXl  COLl  (F)  211110044440009  V0001000094 
B  DXl  COL3  (G)  211110046470109  V0002000095 
B  DXl  COLl  (H)  2111100494900024V0001020096 
B  DX2  (A)  346460041410011  H0001010097 
B  DX2  (B)  346460043430011  H0001010098 
B  DX2  (C)  346460047610111  H0015150099 
B  DX2  (D)  334340041410011  HOOOlOlOlOO 
B  DX2  (E)  334340043430011  HOOOIOIOIOI 
B  DX2  (F)  334340045460111  H0002020102 
B  DX2  (G)  334340048600111  H0013130103 
B  DX2  (H)  334340062630111  H0002020104 
B  DX2  (I)  322220040400011  H0001010105 
B  DX2  (J)  322220042490111  H0008080106 


-4- 


at  03  oa  a  a 


DX2  (K) 
DX2  (L) 
DX2  (M) 
DX2  (N) 
DX2  (O) 
//EOF0497 


322220053590111  H0007070107 
322220061680111  H0008080108 
310100040420111  H0003030109 
310100044440011  HOOOIOIOIIO 
310100046470111  H0002020111 


-5- 


420  AUDIOLOGY/SPEECH 


SCAN420.FIL 


H03830247Ny0051AUDIOLOGY/SPEECH  * 
H010222  * 
B  LITHO  739160104040011  H0024080001 
B  UCA  PFX  2090900706202024V0005010002 
B  UCA  CODE  1  0080800716001024V0012010003 
B  UCA  CODE  2  0070601714501024V0054020004 
B  OTHER  UCA  2171700818100024H0001010005 
B  DATE  (MO)  2434300574601014V0012020006 
B  DATE  (DY)1  1454500555201014V0004010007 
B  DATE  (DY)2  1444400554601014V0010010008 
B  PROVl  PFXl  044440033200109  V0014000009 
B  PROVl  PFX2  0434300322001014V0013010010 
B  PROVl  CODE  1423901332401014V0040040011 
B  SSN  1332501554601014V0090090012 
B  FMP  1373601554601014V0020020013 
B  VISIT  COUNT  2141400544601024V0009010014 
B  PROVl  TIME  2373700351401014V0022020015 
B  PROV2  PFXl  029290033200109  V0014000016 
B  PROV2  PFX2  0282800322001024V0013010017 
B  PROV2  CODE  1272401332401024V0040040018 
B  PROV2  TIME  2313100351401024V0022020019 
BREASON  FOR  #2  (1)  230300011090109  V0003000020 
BREASON  FOR  #2  (2)  2272501080800024H0003010021 
B  IF  NOT  SCHED  2171700717001024V0002010022 
BIF  NOT  CLINIC  (1)  217170063610109  V0003000023 
BIF  NOT  CLINIC  (2)  2141201606000024H0003010024 
B  REF  CODE  PFX  2040400706002024V0006010025 
B  REF  CODE  1  0030300716001024V0012010026 
B  REF  CODE  2  0020101714501024V0054020027 
B  JOB  RELATED  217170032320011  V0001010028 
B  MIL  ONLY  DUTY  2202000241410024V0002010029 
B  MIL  ONLY  QTRS  2191900222001024V0003010030 
B  MIL  ONLY  PROF  2191900181501024V0004010031 
F  FILLER  805  050032 
B  SPEC  PRE  CLIN  306060022140111  H0009090033 
B  NOT  AVAILABLE  320200009070111  H0003030034 
BPROV2  ADDLl  (YES)  208080006060011  V0001010035 
B  ADDL  PROCl  1110701071601024V0050050036 
BPROV2  ADDL2  (YES)  202020006060011  V0001010037 
B  ADDL  PROC2  1050101071601024V0050050038 
F  ADMITTED  801  010039 
BUNL  REAS  PRIM  PFX  2121200747602024V0002010040 
B  UNL  REAS  PRIM  1110701748301034V0050050041 
B  UNL  REAS  SEC  PFX  2060600747602024V0002010042 
B  UNL  REAS  SEC  1050101748301034V0050050043 
B  FOLLOW/R  OUT  23838004 14001024V0002010044 
B  PROC  PROVl  (A)  347470008120111  H0005050045 
B  PROC  PROVl  (B)  347470014190111  H0006060046 
B  PROC  PROVl  (C)  347470021240111  H0004040047 
B  PROC  PROVl  (D)  323230009150111  H0007070048 
B  PROC  PROVl  (E)  323230018250111  H0008080049 
B  PROC  PROVl  (F)  323230028370111  H0010100050 
B  PROC  PROVl  (G)  311110020220111  H0003030061 
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B  PROC  PROVl  (H)  311110025300111  H0006060052 
B  PROC  PROV2  (A)  346460008120111  H0005050053 
B  PROC  PROV2  (B)  346460014190111  H0006060054 
B  PROC  PROV2  (C)  346460021240111  H0004040055 
B  PROC  PROV2  (D)  322220009150111  H0007070056 
B  PROC  PROV2  (E)  322220018250111  H0008080057 
B  PROC  PROV2  (F)  322220028370111  H0010100058 
B  PROC  PROV2  (G)  310100020220111  H0003030059 
B  PROC  PROV2  (H)  310100025300111  H0006060060 
B  DXl  COLl  (A)  247470046500109  V0005000061 
B  DXl  COLl  (B)  247470052570109  V0006000062 
B  DXl  COLl  (C)  247470059630109  V0005000063 
B  DXl  COLl  (D)  247470065670109  V0003000064 
B  DXl  COLl  (E)  247470070730109  V0004000065 
B  DXl  COLl  (F)  247470075760109  V0002000066 
B  DXl  COLl  (G)  2474700788301024V0006020067 
B  DXl  COL2  U)  235350046670109  V0022000068 
B  DXl  COL2  (B)  235350069690009  V0001000069 
B  DXl  COL2  (C)  235350071740109  V0004000070 
B  DXl  COL2  (D)  2353500767600024V0001020071 
B  DXl  COL3  (A)  223230044500109  V0007000072 
B  DXl  COL3  (B)  223230053550109  V0003000073 
B  DXl  COL3  (C)  2232300575700024V0001020074 
B  DX2  (A)  346460046500111  H0005050075 
B  DX2  (B)  346460052570111  H0006060076 
B  DX2  (C)  346460059630111  H0005050077 
B  DX2  (D)  346460065670111  H0003030078 
B  DX2  (E)  346460070730111  H0004040079 
B  DX2  (F)  346460075760111  H0002020080 
B  DX2  (G)  346460078830111  H0006060081 
B  DX2  (H)  334340046670111  H0022220082 
B  DX2  (I)  334340069690011  H0001010083 
B  DX2  (J)  334340071740111  H0004040084 
B  DX2  (Jl)  334340076760011  H0001010085 
B  DX2  (K)  322220044500111  H0007070086 
B  DX2  (L)  322220053550111  H0003030087 
//EOF0510 
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430  ,ARDIOLOGY 


SCAN430.FIL 


H03830247NY0051CARDIOLOGY  * 
H010223  * 
B  LITHO  739160104040011  H0024080001 
B  UCA  PFX  2090900706202024V0005010002 
B  UCA  CODE  1  0080800716001024V0012010003 
B  UCA  CODE  2  0070601714501024V0054020004 
B  OTHER  UCA  2171700818100024H0001010005 
B  DATE  (MO)  2434300574601014V0012020006 
B  DATE  (DY)1  1454500555201014V0004010007 
B  DATE  (DY)2  1444400554601014V0010010008 
B  PROVl  PFXl  044440033200109  V0014000009 
B  PROVl  PFX2  0434300322001014V0013010010 
B  PROVl  CODE  1423901332401014V0040040011 
B  SSN  1332501554601014V0090090012 
B  FMP  1373601554601014V0020020013 
B  VISIT  COUNT  2141400544601024V0009010014 
B  PROVl  TIME  2373700351401014V0022020015 
B  PROV2  PFXl  029290033200109  V0014000016 
B  PROV2  PFX2  0282800322001024V0013010017 
B  PROV2  CODE  1272401332401024V0040040018 
B  PROV2  TIME  2313100351401024V0022020019 
BREASON  FOR  #2  (1)  230300011090109  V0003000020 
BREASON  FOR  #2  (2)  2272501080800024H0003010021 
B  IF  NOT  SCHED  2171700717001024V0002010022 
BIF  NOT  CLINIC  (1)  217170063610109  V0003000023 
BIF  NOT  CLINIC  (2)  2 14 1201606000024H0003010024 
B  REF  CODE  PFX  2040400706002024V0006010025 
B  REF  CODE  1  0030300716001024V0012010026 
B  REF  CODE  2  0020101714501024V0054020027 
B  JOB  RELATED  217170032320011  V0001010028 
B  MIL  ONLY  DUTY  2202000241410024V0002010029 
B  MIL  ONLY  QTRS  2191900222001024V00030I0030 
B  MIL  ONLY  PROF  2191900181501024V0004010031 
F  FILLER  805  050032 
B  SPEC  PRE  CLIN  306060022140111  H0009090033 
B  NOT  AVAILABLE  320200009070111  H0003030034 
BPROV2  ADDLl  (YES)  208080006060011  V0001010035 
B  ADDL  PROCl  1110701071601024V0050050036 
BPROV2  ADDL2  (YES)  202020006060011  V0001010037 
B  ADDL  PROC2  1050101071601024V0050050038 
B  ADMITTED  223230016160011  V0001010039 
BUNL  REAS  PRIM  PFX  2121200747602024V0002010040 
B  UNL  REAS  PRIM  1110701748301034V0050050041 
B  UNL  REAS  SEC  PFX  2060600747602024V0002010042 
B  UNL  REAS  SEC  1050101748301034V005005004 3 
B  FOLLOW/R  OUT  2383800272601024V0002010044 


B 

PROC 

PROVl 

(A) 

347470008150111 

H0008080045 

B 

PROC 

PROVl 

(B) 

347470018190111 

H0002020046 

B 

PROC 

PROVl 

(C) 

347470021240111 

H0004040047 

B 

PROC 

PROVl 

(D) 

335350008110111 

H0004040048 

B 

PROC 

PROVl 

(E) 

335350014150111 

H0002020049 

B 

PROC 

PROVl 

(F) 

335350018200111 

H0003030050 

B 

PROC 

PROVl 

(G) 

323230008100111 

H0003030051 
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|B 

B 

PROC  PROVl  (H) 

323230012140111 

H0003030052 

B 

PROC  PROV2  (A) 

346460008150111 

H0008080053 

1 

B 

PROC  PROV2  (B) 

346460018190111 

H0002020054 

1 

B 

PROC  PROV2  (C) 

346460021240111 

H0004040055 

—■ 

B 

PROC  PROV2  (D) 

334340008110111 

H0004040056 

B 

PROC  PROV2  (E) 

334340014150111 

HC002020057 

B 

PROC  PROV2  (F) 

334340018200111 

H0003030058 

B 

PROC  PROV2  (G) 

322220008100111 

H0003030059 

B 

PROC  PROV2  (H) 

322220012140111 

H0003030060 

B 

DXl 

COLl 

(A) 

247470031330109 

V0003000061 

B 

DXl 

COLl 

(B) 

247470036440109 

V0009000062 

B 

DXl 

COLl 

(C) 

247470047500109 

V0004000063 

B 

DXl 

COLl 

(D) 

247470053530009 

V0001000064 

B 

DXl 

COLl 

(E) 

247470055700109 

V0016000065 

B 

DXl 

COLl 

(F) 

247470072760109 

V0005000066 

B 

DXl 

COLl 

(G) 

2474700798301024V0005020067 

B 

DXl 

COL2 

(A) 

235350029340109 

V0006000068 

B 

DXl 

COL2 

(B) 

235350036400109 

V0005000069 

B 

DXl 

COL2 

(C) 

235350043470109 

V0005000070 

B 

DXl 

COL2 

(D) 

235350050530109 

V0004000071 

B 

DXl 

COL2 

(E) 

235350056580109 

V0003000072 

B 

DXl 

COL2 

(F) 

235350061630109 

V0003000073 

■( 

B 

DXl 

COL2 

(G) 

235350066690109 

V0004000074 

B 

DXl 

COL2 

(H) 

2353500727501024V0004020075 

B 

DXl 

COL3 

(A) 

223230029340109 

V0006000076 

B 

DXl 

COL3 

(B) 

223230036360009 

V0001000077 

B 

DXl 

COL3 

(C) 

223230039470109 

V0009000078 

9 

B 

DXl 

COL3 

(D) 

223230051560109 

V0006000079 

■jj 

B 

DXl 

COL3 

(E) 

223230058620109 

V0005000080 

B 

DXl 

COL3 

(P) 

2232300646901024V0006020081 

B 

DXl 

COL4 

(A) 

211110029320109 

V0004000082 

B 

DXl 

COL4 

(B) 

211110034380109 

V0005000083 

B 

DXl 

COL4 

(C) 

211110040440109 

V0005000084 

. 

B 

DXl 

COL4 

(D) 

211110047530109 

V0007000085 

Jl 

B 

DXl 

COL4 

(E) 

211110055590109 

V0005000086 

B 

DXl 

COL4 

(F) 

211110062640109 

V0003000087 

B 

DXl 

COL4 

(G) 

2111100666600024V0001020088 

B 

DX2  (A) 

346460031330111 

H0003030089 

B 

DX2  (B) 

346460036440111 

H0009090090 

B 

DX2  (C) 

346460047500111 

H0004040091 

A 

B 

DX2  (D) 

346460053530011 

H0001010092 

B 

DX2  (E) 

346460055700111 

H0016160093 

B 

DX2  (F) 

346460072760111 

H0005050094 

B 

DX2  (G) 

346460079830111 

H0005050095 

B 

DX2  (H) 

334340029340111 

H0006060096 

B 

DX2  (I) 

334340036400111 

H0005050097 

Jl 

B 

DX2  (J) 

334340043470111 

H0005050098 

B 

DX2  (K) 

334340050530111 

H0004040099 

B 

DX2  (L) 

334340056580111 

H0003030100 

B 

DX2  (M) 

334340061630111 

H0003030101 

B 

DX2  (N) 

334340066690111 

H0004040102 

B 

DX2  (0) 

334340072750111 

H0004040103 

m 

B 

DX2  (P) 

322220029340111 

H0006060104 

B 

DX2  {Q) 

322220036360011 

H0001010105 

' 

B 

nx2  (R) 

322220039470111 

H0009090106 

-9- 


Jl 


O9tSD}Q)C0aOOUD) 


« 


I 


DX2 

(S) 

DX2 

(T) 

DX2 

(U) 

DX2 

(V) 

DX2 

(W) 

DX2 

(X) 

DX2 

(Y) 

DX2 

(Z) 

DX2 

(AA) 

//EOF0540 


322220051560111 

322220058620111 

322220064690111 

310100029320111 

310100034380111 

310100040440111 

310100047530111 

310100055590111 

310100062640111 


H0006060107 

H0005050108 

H0006060109 

H0004040110 

H0005050111 

H0005050112 

H0007070113 

H0005050114 

H0003030115 
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440  CARDIOTHERAPY 


SCAN440.FIL 


I 


(t 


H03830247NY0051CARDIOTHERAPY  * 
H010218  * 
B  LITHO  739160104040011  H0024080001 
B  UCA  PFX  2090900706202024V0005010002 
B  UCA  CODE  1  0080800716001024V0012010003 
B  UCA  CODE  2  0070601714501024V0054020004 
F  OTHER  UCA  801  010005 
B  DATE  (MO)  2434300574601014V0012020006 
B  DATE  (DY)1  1454500555201014V0004010007 
B  DATE  (DY)2  1444400554601014V0010010008 
B  PROVl  PFXl  044440033200109  V0014000009 
B  PROVl  PFX2  0434300322001014V0013010010 
B  PROVl  CODE  1423901332401014V0040040011 
B  SSN  1332501554601014V0090090012 
B  FMP  1373601554601014V0020020013 
B  VISIT  COUNT  2141400544601024V0009010014 
B  PROVl  TIME  2373700351401014V0022020015 
B  PROV2  PFXl  029290033200109  V0014000016 
B  PROV2  PFX2  0282800322001024V0013010017 
B  PROV2  CODE  1272401332401024V0040040018 
B  PROV2  TIME  23 13100351401024V0022020019 
BREASON  FOR  #2  (1)  230300011090109  V0003000020 
BREASON  FOR  #2  (2)  2272501080800024H0003010021 
B  IF  NOT  SCHED  2171700717001024V0002010022 
BIF  NOT  CLINIC  (1)  217170063610109  V0003000023 
BIF  NOT  CLINIC  (2)  2141201606000024H0003010024 
B  REF  CODE  PFX  2040400706002024V0006010025 
B  REF  CODE  1  0030300716001024V0012010026 
B  REF  CODE  2  0020101714501024V0054020027 
B  JOB  RELATED  217170032320011  V0001010028 
B  MIL  ONLY  DUTY  2202000241410024V0002010029 
B  MIL  ONLY  QTRS  2191900222001024V0003010030 
B  MIL  ONLY  PROF  2191900181501024V0004010031 
F  FILLER  805  050032 
B  SPEC  PRE  CLIN  306060022140111  H0009090033 
B  NOT  AVAILABLE  320200009070111  H0003030034 
BPROV2  ADDLl  (YES)  208080006060011  V0001010035 
B  ADDL  PROCl  1110701071601024V0050050036 
BPROV2  ADDL2  (YES)  202020006060011  V0001010037 
B  ADDL  PROC2  1050101071601024V0050050038 
B  ADMITTED  247470023230011  V0001010039 
BUNL  REAS  PRIM  PFX  2 12 1200747602024V0002010040 
B  UNL  REAS  PRIM  1110701748301034V005005004 1 
B  UNL  REAS  SEC  PFX  2060600747602024V0002010042 
B  UNL  REAS  SEC  1050101748301034V0050050043 
B  FOLLOW/R  OUT  2383800272601024V0002010044 
B  PROC  PROVl  347470007210111  H0015150045 
B  PROC  PROV2  346460007210111  H0015150046 
B  DXl  COLl  (A)_  247470032350109  V0004000047 
B  DXl  COLl  (B)_  247470037420109  V0006000048 
B  DXl  COLl  (C)_  247470045480109  V0004000049 
B  DXl  COLl  (D)_  247470051580109  V0008000050 
D  DXl  COL]  <'E)_  2474700617501024V0015020051 
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DXl  C0L2  (A)_  235350029350109  V0007000052 

DXl  COL2  (B)_  235350038390109  V0002000053 

DXl  COL2  (C)_  235350042470109  V0006000054 

DXl  COL2  (D)_  235350050530109  V0004000055 

DXl  COL2  (E)_  235350056590109  V0004000056 

DXl  COL2  (F)_  2353500626601024V0005020057 

DXl  COL3  (A)_  223230029410109  V0013000058 

DXl  COL3  (B)_  223230044500109  V0007000059 

DXl  COL3  (C)_  2232300536001024V0008020060 

DXl  COL4  (A)_  211110029370109  V0009000061 

DXl  COL4  (B)_  211110040430109  V0004000062 

DXl  COL4  (C)_  211110046530109  V0008000063 

DXl  COL4  (D)_  211110056590109  V0004000064 

DXl  COL4  (E)_  2111100626301024V0002020065 

DX2  (A)  346460032350111  H0004040066 

DX2  (B)  346460037420111  H0006060067 

DX2  (C)  346460045480111  H0004040068 

DX2  (D)  346460051580111  H0008080069 

DX2  (E)  346460061750111  H0015150070 

DX2  (F)  334340029350111  H0007070071 

DX2  (G)  334340038390111  H0002020072 

DX2  (H)  334340042470111  H0006060073 

DX2  (I)  334340050530111  H0004040074 

DX2  (J)  334340056590111  H0004040075 

DX2  (K)  334340062660111  H0005050076 

DX2  (L)  322220029410111  H0013130077 

DX2  (M)  322220044500111  H0007070078 

DX2  (N)  322220053600111  H0008080079 

DX2  (0)  310100029370111  H0009090080 

DX2  (P)  310100040430111  H0004040081 

DX2  (Q)  310100046530111  H0008080082 

DX2  (R)  310100056590111  H0004040083 

DX2  (S)  310100062630111  H0002020084 
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450  DERMATOLOGY 


SCAN450.FIL 


H03830247NY0051DERMATOLOGY  * 
H010228  * 
B  LITHO  739160104040011  H0024080001 
B  UCA  PFX  2090900706202024V0005010002 
B  UCA  CODE  1  0080800716001024V0012010003 
B  UCA  CODE  2  0070601714501024V0054020004 
F  OTHER  UCA  801  010005 
B  DATE  (MO)  2434300574601014V0012020006 
B  DATE  (DY)1  1454500555201014V0004010007 
B  DATE  (DY)2  1444400554601014V0010010008 
B  PROVl  PFXl  044440033200109  V0014000009 
B  PROVl  PFX2  0434300322001014V0013010010 
B  PROVl  CODE  1423901332401014V0040040011 
B  SSN  1332501554601014V0090090012 
B  FMP  1373601554601014V0020020013 
B  VISIT  COUNT  2141400544601024V0009010014 
B  PROVl  TIME  2373700351401014V0022020015 
B  PROV2  PFXl  029290033200109  V0014000016 
B  PROV2  PFX2  0282800322001024V0013010017 
B  PROV2  CODE  1272401332401024V0040040018 
B  PROV2  TIME  2313100351401024V0022020019 
BREASON  FOR  #2  (1)  230300011090109  V0003000020 
BREASON  FOR  #2  (2)  2272501080800024H0003010021 
B  IF  NOT  SCHED  2171700717001024V0002010022 
BIF  NOT  CLINIC  (1)  217170063610109  V0003000023 
BIF  NOT  CLINIC  (2)  2141201606000024H0003010024 
B  REF  CODE  PFX  2040400706002024V0006010025 
B  REF  CODE  1  0030300716001024V0012010026 
B  REF  CODE  2  0020101714501024V0054020027 
B  JOB  RELATED  217170032320011  V0001010028 
B  MIL  ONLY  DUTY  2202000241410024V0002010029 
B  MIL  ONLY  QTRS  2191900222001024V0003010030 
B  MIL  ONLY  PROF  2191900181501024V0004010031 
F  FILLER  805  050032 
B  SPEC  PRE  CLIN  306060022140111  H0009090033 
B  NOT  AVAILABLE  320200009070111  H0003030034 
BPROV2  ADDLl  (YES)  208080006060011  V0001010035 
B  ADDL  PROCl  1110701071601024V0050050036 
BPROV2  ADDL2  (YES)  202020006060011  V0001010037 
B  ADDL  PROC2  1050101071601024V0050050038 
B  ADMITTED  211110036360011  V0001010039 
BUNL  REAS  PRIM  PFX  2121200747602024V0002010040 
B  UNL  REAS  PRIM  1110701748301034V0050050041 
B  UNL  REAS  SEC  PFX  2060600747602024V0002010042 
B  UNL  REAS  SEC  1050101748301034V0050050043 
B  FOLLOW/R  OUT  2383800393801024V0002010044 
BPROC  PROVl  (A)  347470008130111  H0006060045 
BPROC  PROVl  (B)  347470015190111  H0005050046 
BPROC  PROVl  (C)  347470021260111  H0006060047 
BPROC  PROVl  (D)  347470028300111  H0003030048 
BPROC  PROVl  (E)  347470032360111  H0005050049 
BPROC  PROVl  (F)  335350008090111  H0002020050 
BPROC  PROVl  (G)  335350011160111  H0006060051 
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BPROC  PROVl  (H)  335350018200111  H0003030052 
BPROC  PROVl  (I)  335350022260111  H0005050053 
BPROC  PROVl  (J)  335350028310111  H0004040054 
BPROC  PROVl  (K)  335350033360111  H0004040055 
BPROC  PROVl  (L)  323230007110111  H0005050056 
BPROC  PROVl  (M)  323230013210111  H0009090057 
BPROC  PROVl  (N)  323230023250111  H0003030058 
BPROC  PROVl  (O)  323230027320111  H0006060059 
BPROC  PROVl  (P)  323230034360111  H0003030060 
BPROC  PROVl  (Q)  311110019350111  H0017170061 
BPROC  PROV2  (A)  346460008130111  H0006060062 
BPROC  PROV2  (B)  346460015190111  H0005050063 
BPROC  PROV2  (C)  346460021260111  H0006060064 
BPROC  PROV2  (D)  346460028300111  H0003030065 
BPROC  PROV2  (E)  346460032360111  H0005050066 
BPROC  PROV2  (F)  334340008090111  H0002020067 
BPROC  PROV2  (G)  334340011160111  H0006060068 
BPROC  PROV2  (H)  334340018200111  H0003030069 
BPROC  PROV2  (I)  334340022260111  H0005050070 
BPROC  PROV2  (J)  334340028310111  H0004040071 
BPROC  PROV2  (K)  334340033360111  H0004040072 
BPROC  PROV2  (L)  322220007110111  H0005050073 
BPROC  PROV2  (M)  322220013210111  H0009090074 
BPROC  PROV2  (N)  322220023250111  H0003030075 
BPROC  PROV2  (O)  322220027320111  H0006060076 
BPROC  PROV2  (P)  322220034360111  H0003030077 
BPROC  PROV2  (Q)  310100019350111  H0017170078 
B  DXl  COLl  2474700428301024V0042020079 
B  DXl  COL2  2353500408201024V0043020080 
B  DXl  COL3  2232300408301024V0044020081 
B  DXl  COL4  (A)  211110040660109  V0027000082 
B  DXl  COL4  (B)  2111100686800024V0001020083 
B  DX2  (A)  346460042830111  H0042420084 
B  DX2  (B)  334340040820111  H0043430085 
B  DX2  (C)  322220040830111  H0044440086 
B  DX2  (D)  310100040660111  H0027270087 
//EOF0685 
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460  ENDOCRINE 


H03830247NY0051ENDOCRINE  * 
H010242  * 
B  LITHO  739160104040011  H0024080001 
B  UCA  PFX  2090900706202024V0005010002 
B  UCA  CODE  1  0080800716001024V0012010003 
B  UCA  CODE  2  0070601714501024V0054020004 
F  OTHER  UCA  801  010005 
B  DATE  (MO)  2434300574601014V0012020006 
B  DATE  (DY)1  1454500555201014V0004010007 
B  DATE  (DY)2  1444400554601014V0010010008 
B  PROVl  PFXl  044440033200109  V0014000009 
B  PROVl  PFX2  0434300322001014V0013010010 
B  PROVl  CODE  1423901332401014V0040040011 
B  SSN  1332501554601014V0090090012 
B  FHP  1373601554601014V0020020013 
B  VISIT  COUNT  2141400544601024V0009010014 
B  PROVl  TIME  2373700351401014V0022020015 
B  PROV2  PFXl  029290033200109  V0014000016 
B  PROV2  PFX2  0282800322001024V0013010017 
B  PROV2  CODE  1272401332401024V0040040018 
B  PROV2  TIME  2313100351401024V0022020019 
BREASON  FOR  #2  (1)  230300011090109  V0003000020 
BREASON  FOR  #2  (2)  2272501080800024H0003010021 
B  IF  NOT  SCHED  2171700717001024V0002010022 
BIF  NOT  CLINIC  (1)  217170063610109  V0003000023 
BIF  NOT  CLINIC  (2)  2141201606000024H0003010024 
B  REF  CODE  PFX  2040400706002024V0006010025 
B  REF  CODE  1  0030300716001024V0012010026 
B  REF  CODE  2  0020101714501024V0054020027 
B  JOB  RELATED  217170032320011  V0001010028 
B  MIL  ONLY  DUTY  2202000241410024V0002010029 
B  MIL  ONLY  QTRS  2191900222001024V0003010030 
B  MIL  ONLY  PROF  2191900181501024V0004010031 
F  FILLER  805  050032 
B  SPEC  PRE  CLIN  306060022140111  H0009090033 
B  NOT  AVAILABLE  320200009070111  H0003030034 
BPROV2  ADDLl  (YES)  208080006060011  V0001010035 
B  ADDL  PROCl  1110701071601024V0050050036 
BPROV2  ADDL2  (YES)  202020006060011  V0001010037 
B  ADDL  PROC2  105010107 1601024V0050050038 
B  ADMITTED  247470019190011  V0001010039 
BUNL  REAS  PRIM  PFX  2121200747602024V0002010040 
B  UNL  REAS  PRIM  1110701748301034V0050050041 
B  UNL  REAS  SEC  PFX  2060600747602024V0002010042 
B  UNL  REAS  SEC  1050101748301034V0050050043 
B  FOLLOW/  R  OUT  2383800272601024V0002010044 
B  PROC  PROVl  347470007160111  H0010100045 
B  PROC  PROV2  346460007160111  H0010100046 
BDXl  COLl  (A)  247470031380109  V0008000047 
BDXl  COLl  (B)  2474700415001024V0010020048 
BDXl  COL2  (A)  235350029340109  V0006000049 
BDXl  COL2  (B)  235350037400109  V0004000050 
BDXl  COL2  (C)  2353500435001024V0008020051 
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BDXl 

COL3 

(A) 

BDXl 

COL3 

(B) 

BDXl 

COL3 

(C) 

BDXl 

COL3 

(D) 

BDXl 

COL3 

(E) 

BDXl 

COL3 

(F) 

BDXl 

COL3 

(G) 

B 

DX2 

(A) 

B 

DX2 

(B) 

B 

DX2 

(C) 

B 

DX2 

(D) 

B 

DX2 

(E) 

B 

DX2 

(F) 

B 

DX2 

(G) 

B 

DX2 

(H) 

B 

DX2 

(I) 

B 

DX2 

(J) 

B 

DX2 

(K) 

223230029350109  V0007000052 
223230038470109  V0010000053 
211110029300109  V0002000054 
211110032350109  V0004000055 
211110037370009  V0001000056 
211110039390009  V0001000057 
2111100414100024V0001020058 
346460031380111  H0008080059 
346460041500111  H0010100060 
334340029340111  H0006060061 
334340037400111  H0004040062 
334340043500111  H0008080063 
322220029350111  H0007070064 
322220038470111  H0010100065 
310100029300111  H0002020066 
310100032350111  H0004040067 
310100037370011  H0001010068 
310100039390011  H0001010069 


//EOF0426 
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470  ENT 


SCAN470.FIL 


H03830247NY0051ENT 
H010243 
B  LITHO 

B  UCA  PFX 

B  UCA  CODE  1 

B  UCA  CODE  2 

F  OTHER  UCA 

B  DATE  (MO) 

B  DATE  (DY)1 

B  DATE  (DY)2 

B  PROVl  PFXl 

B  PROVl  PFX2 

B  PROVl  CODE 

B  SSN 

B  FMP 

B  VISIT  COUNT 

B  PROVl  TIME 

B  PROV2  PFXl 

B  PROV2  PFX2 

B  PRO\ ^  CODE 

B  PROV2  TIME 

BREASON  FOR  #2  (1) 
BREASON  FOR  #2  (2) 
B  IF  NOT  SCHED 

BIF  NOT  CLINIC  (1) 
BIF  NOT  CLINIC  (2) 
B  REF  CODE  PFX 

B  REF  CODE  1 

B  REF  CODE  2 

B  JOB  RELATED 
B  MIL  ONLY  DUTY 

B  MIL  ONLY  QTRS 

B  MIL  ONLY  PROF 

F  FILLER 

B  SPEC  PRE  CLIN 

B  NOT  AVAILABLE 

BPROV2  ADDLl  (YES) 
B  ADDL  PROCl 

BPROV2  ADDL2  (YES) 
B  ADDL  PROC2 

B  ADMITTED 
BUNL  REAS  PRIM  PFX 
B  UNL  REAS  PRIM 

B  UNL  REAS  SEC  PFX 
B  UNL  REAS  SEC 

B  FOLLOW/R  OUT 

B  PROC  PROVl  (A) 

B  PROC  PROVl  (B) 

B  PROC  PROVl  (C) 

B  PROC  PROVl  (D) 

B  PROC  pnovi  (E) 

B  PROC  PkOVI  (F) 

B  PROC  PROVl  (G) 


* 

* 

739160104040011  H0024080001 
2090900706202024V0005010002 
0080800716001024V0012010003 
0070601714501024V0054020004 
801  010005 

2434300574601014V0012020006 
1454500555201014V0004010007 
1444400554601014V0010010008 
044440033200109  V0014000009 
0434300322001014V0013010010 
1423901332401014V0040040011 
1332501554601014V0090090012 
1373601554601014V0020020013 
2 141400544 601024V0009010014 
2373700351401014V0022020015 
029290033200109  V0014000016 
0282800322001024V0013010017 
1272401332401024V0040040018 
2313100351401024V0022020019 
230300011090109  V0003000020 
2272501080800024H0003010021 
2171700717001024V0002010022 
217170063610109  V0003000023 
2141201606000024H0003010024 
2040400706002024V0006010025 
0030300716001024V0012010026 
0020101714501024V0054020027 
217170032320011  V0001010028 
2202000241410024V0002010029 
2191900222001024V0003010030 
2191900181501024V0004010031 
805  050032 

306060022140111  H0009090033 
320200009070111  H0003030034 
208080006060011  V0001010035 
1110701071601024V0050050036 
202020006060011  V0001010037 
1050101071601024V0050050038 
223230022220011  V0001010039 
2121200747602024V0002010040 
1110701748301034V0050050041 
2060600747602024V0002010042 
1050101748 3 0103 4V005005004 3 
2 38380036350102 4V0002010044 
347470008160111  H0009090045 
347470019300111  H0012120046 
335350008090111  H0002020047 
335350011150111  H0005050048 
335350017170011  H0001010049 
323230008180111  H0011110050 
323230020200011  HOOOiOlOOSl 


-17- 


B 

PROC 

PROV2 

(A) 

346460008160111 

H0009090052 

B 

PROC 

PROV2 

(B) 

346460019300111 

H0012120053 

B 

PROC 

PROV2 

(C) 

334340008090111 

H0002020054 

B 

PROC 

PROV2 

(D) 

334340011150111 

H0005050055 

B 

PROC 

PROV2 

(E) 

334340017170011 

H0001010056 

B 

PROC 

PROV2 

(F) 

322220008180111 

H0011110057 

B 

PROC 

PROV2 

(G) 

322220020200011 

H0001010058 

B 

DXl 

COLl 

(A) 

247470040430109 

V0004000059 

B 

DXl 

COLl 

(B) 

247470045490109 

V0005000060 

B 

DXl 

COLl 

(C) 

247470051560109 

V0006000061 

B 

DXl 

COLl 

(D) 

2474700586701024V0010020062 

B 

DXl 

COL2 

(A) 

235350038450109 

V0008000063 

B 

DXl 

COL2 

(B) 

235350047500109 

V0004000064 

B 

DXl 

COL2 

(C) 

235350052570109 

V0006000065 

B 

DXl 

COL2 

(D) 

2353500607801024V0019020066 

B 

DXl 

COL3 

(A) 

223230038390109 

V0002000067 

B 

DXl 

COL3 

(B) 

223230043580109 

V0016000068 

B 

DXl 

COL3 

(C) 

2232300616201024V0002020069 

B 

DXl 

COL4 

(A) 

211110038400109 

V0003000070 

B 

DXl 

COL4 

(B) 

211110042420009 

V0001000071 

B 

DXl 

COL4 

(C) 

211110044470109 

V0004000072 

B 

DXl 

COL4 

(D) 

211110049550109 

V0007000073 

B 

DXl 

COL4 

(E) 

2111100575700024V0001020074 

B 

DX2 

(A) 

346460040430111 

H0004040075 

B 

DX2 

(Al) 

346460045490111 

H0005050076 

B 

DX2 

(B) 

346460051560111 

H0006060077 

B 

DX2 

(C) 

346460058670111 

H0010100078 

B 

DX2 

(D) 

334340038450111 

H0008080079 

B 

DX2 

(E) 

334340047500111 

H0004040080 

B 

DX2 

(F) 

334340052570111 

H0006060081 

B 

DX2 

(G) 

334340060780111 

H0019190082 

B 

DX2 

(H) 

322220038390111 

H0002020083 

B 

DX2 

(I) 

322220043580111 

H0016160084 

B 

DX2 

(J) 

322220061620111 

H0002020085 

B 

DX2 

(K) 

310100038400111 

H0003030086 

B 

DX2 

(L) 

310100042420011 

H0001010087 

B 

DX2 

(M) 

310100044470111 

H0004040088 

B 

DX2 

(N) 

310100049550111 

H0007070089 

//EOF0524 


480  FAMILY  PRACTICE 


SCAN480.FIL 


H03830247Ny0051FAMILY  PRACTICE  * 
H010237  * 
B  LITHO  739160104040011  H0024080001 
B  UCA  PFX  2090900706202024V0005010002 
B  UCA  CODE  1  0080800716001024V0012010003 
B  UCA  CODE  2  0070601714501024V0054020004 
B  OTHER  UCA  2171700818100024V0001010005 
B  DATE  (MO)  2434300574601014V0012020006 
B  DATE  (DY)1  1454500555201014V0004010007 
B  DATE  (DY)2  1444400554601014V0010010008 
B  PROVl  PFXl  044440033200109  V0014000009 
B  PROVl  PFX2  0434300322001014V0013010010 
B  PROVl  CODE  1423901332401014V0040040011 
B  SSN  1332501554601014V0090090012 
B  FMP  1373601554601014V0020020013 
B  VISIT  COUNT  2141400544601024V0009010014 
B  PROVl  TIME  2373700351401014V0022020015 
B  PROV2  PFXl  029290033200109  V0014000016 
B  PROV2  PFX2  0282800322001024V0013010017 
B  PROV2  CODE  1272401332401024V0040040018 
B  PROV2  TIME  2313100351401024V0022020019 
BREASON  FOR  #2  (1)  230300011090109  V0003000020 
BREASON  FOR  #2  (2)  2272501080800024H0003010021 
B  IF  NOT  SCHED  2171700717001024V0002010022 
BIF  NOT  CLINIC  (1)  217170063610109  V0003000023 
BIF  NOT  CLINIC  (2)  2141201606000024H0003010024 
B  REF  CODE  PFX  2040400706002024V0006010025 
B  REF  CODE  1  0030300716001024V0012010026 
B  REF  CODE  2  0020101714501024V0054020027 
B  JOB  RELATED  217170032320011  V0001010028 
B  MIL  ONLY  DUTY  2202000241410024VJ002010029 
B  MIL  ONLY  QTRS  2191900222001024V0003010030 
B  MIL  ONLY  PROF  2191900181501024V0004010031 
F  FILLER  805  050032 
B  SPEC  PRE  CLIN  306060022140111  H0009090033 
B  NOT  AVAILABLE  320200009070111  H0003030034 
BPROV2  ADDLl  (YES)  208080006060011  V0001010035 
B  ADDL  PROCl  1110701071601024V0050050036 
BPROV2  ADDL2  (YES)  202020006060011  V0001010037 
B  ADDL  PROC2  1050101071601024V0050050038 
B  ADMITTED  235350014140011  V0001010039 
BUNL  REAS  PRIM  PFX  2121200747602024V0002010040 
B  UNL  REAS  PRIM  1110701748301034V0050050041 
B  UNL  REAS  SEC  PFX  2060600747602024V0002010042 
B  UNL  REAS  SEC  1050101748301034V0050050043 
B  FOLLOW/R  OUT  2383800222101024V0002010044 
B  PROC  PROVl  (A)  347470007180111  H0012120045 
B  PROC  PROVl  (B)  335350008100111  H0003030046 
B  PROC  PROVl  (C)  335350012120011  H0001010047 
B  PROC  PROV2  (A)  346460007180111  H0012120048 
B  PROC  PROV2  (B)  334340008100111  H0003030049 
B  PROC  P'IOV2  (C)  334340012120011  H0001010050 
B  DXl  COLl  (A)  247470026320109  V0007000051 


-19- 


(qfiQOQCQaoQCQflQCQCQCQCQCOnCQCQCQaacOfOaSPQOQCQCQOQCQCQCQCQBQCQCQCQCQOQCQCQcaniQnCQOQoanaacQflQCQCQOQOQflQCQ 


DXl  COLl  (B)  247470034390109  V0006000052 

DXl  COLl  (C)  247470043540109  V0012000053 

DXl  COLl  (D)  247470056630109  V0008000054 

DXl  COLl  (E)  247470065710109  V0007000055 

DXl  COLl  (F)  247470073740109  V0002000056 

DXl  COLl  (G)  2474700768101024V0006020057 

DXl  C0L2  (A)  235350024330109  V0010000058 

DXl  C0L2  (B)  235350036570109  V0022000059 

DXl  C0L2  (C)  235350060600009  V0001000060 

DXl  C0L2  (D)  2353500637001024V0008020061 

DXl  COL3  (A)  223230024460109  V0023000062 

DXl  C0L3  (B)  223230049560109  V0008000063 

DXl  C0L3  (C)  223230059620109  V0004000064 

DXl  C0L3  (D)  223230065660109  V0002000065 

DXl  COL3  (E)  223230071720109  V0002000066 

DXl  C0L3  (F)  223230074740009  V0001000067 

DXl  C0L3  (G)  223230076760009  V0001000068 

DXl  C0L3  (H)  2232300787800024V0001020069 

DXl  C0L4  (A)  211110025310109  V0007000070 

DXl  C0L4  (B)  211110033340109  V0002000071 

DXl  C0L4  (C)  211110036360009  V0001000072 

DXl  C0L4  (D)  211110038430109  V0006000073 

DXl  C0L4  (E)  211110046460009  V0001000074 

DXl  C0L4  (F)  211110048480009  V0001000075 

DXl  C0L4  (G)  211110050510109  V0002000076 

DXl  C0L4  (H)  211110054540009  V0001000077 

DXl  C0L4  (I)  211110056590109  V0004000078 

DXl  C0L4  (J)  211110062620009  V0001000079 

DXl  C0L4  (K)  2111100646501024V0002020080 

DX2  (A)  346460026320111  H0007070081 

DX2  (B)  346460034390111  H0006060082 

DX2  (C)  346460043540111  H0012120083 

DX2  (D)  346460056630111  H0008080084 

DX2  (E)  346460065710111  H0007070085 

DX2  (F)  346460073740111  H0002020086 

DX2  (G)  346460076810111  H0006060087 

DX2  (H)  334340024330111  H0010100088 

DX2  (I)  334340036570111  H0022220089 

DX2  (J)  334340060600011  H0001010090 

DX2  (K)  334340063700111  H0008080091 

DX2  (L)  322220024460111  H0023230092 

DX2  (M)  322220049560111  H0008080093 

DX2  (N)  322220059620111  H0004040094 

DX2  (O)  322220065660111  H0002020095 

DX2  (P)  322220071720111  H0002020096 

DX2  (Q)  322220074740011  H0001010097 

DX2  (R)  322220076760011  H0001010098 

DX2  (S)  322220078780011  H0001010099 

DX2  (T)  310100025310111  H0007070100 

DX2  (U)  310100033340111  H0002020101 

DX2  (V)  310100036360011  H0001010102 

DX2  (W)  310100038430111  H0006060103 

DX2  (X)  310100046460011  H0001010104 

DX2  (Y)  310100048480011  H0001010105 

DX2  (Z)  310100050510111  H0002020106 


-20- 


00  00  00 


DX2  (AA)  310100054540011 

DX2  (BB)  310100056590111 

DX2  (CC)  310100062620011 

//EOF0534 


-21- 


H0001010107 

H0004040108 

H0001010109 


490  GASTROENTEROLOGY 


SCAN490.FIL 


H03830247NY0051GASTROENTEROLOGY  * 
H010235  * 
B  LITHO  739160104040011  H0024080001 
B  UCA  PFX  2090900706202024V0005010002 
B  UCA  CODE  1  0080800716001024V0012010003 
B  UCA  CODE  2  0070601714501024V0054020004 
B  OTHER  UCA  2171700818100024H0001010005 
B  DATE  (MO)  2434300574601014V0012020006 
B  DATE  (DY)1  1454500555201014V0004010007 
B  DATE  (DY)2  1444400554601014V0010010008 
B  PROVl  PFXl  044440033200109  V0014000009 
B  PROVl  PFX2  0434300322001014V0013010010 
B  PROVl  CODE  1423901332401014V0040040011 
B  SSN  1332501554601014V0090090012 
B  FMP  1373601554601014V0020020013 
B  VISIT  COUNT  2141400544601024V0009010014 
B  PROVl  TIME  2373700351401014V0022020015 
B  PROV2  PFXl  029290033200109  V0014000016 
B  PROV2  PFX2  0282800322001024V0013010017 
B  PROV2  CODE  1272401332401024V0040040018 
B  PROV2  TIME  2313100351401024V0022020019 
BREASON  FOR  #2  (1)  230300011090109  V0003000020 
BREASON  FOR  #2  (2)  2272501080800024H0003010021 
B  IF  NOT  SCHED  2171700717001024V0002010022 
BIF  NOT  CLINIC  (1)  217170063610109  V0003000023 
BIF  NOT  CLINIC  (2)  2141201606000024H0003010024 
B  REF  CODE  PFX  2040400706002024V0006010025 
B  REF  CODE  1  0030300716001024V0012010026 
B  REF  CODE  2  0020101714501024V0054020027 
B  JOB  RELATED  217170032320011  V0001010028 
B  MIL  ONLY  DUTY  2202000241410024V0002010029 
B  MIL  ONLY  QTRS  2191900222001024V0003010030 
B  MIL  ONLY  PROF  2191900181501024V0004010031 
F  FILLER  805  050032 
B  SPEC  PRE  CLIN  306060022140111  H0009090033 
B  NOT  AVAILABLE  320200009070111  H0003030034 
BPROV2  ADDLl  (YES)  208080006060011  V0001010035 
B  ADDL  PROCl  1110701071601024V0050050036 
BPROV2  ADDL2  (YES)  202020006060011  V0001010037 
B  ADDL  PROC2  1050101071601024V0050050038 
B  ADMITTED  223230019190011  V0001010039 
BUNL  REAS  PRIM  PFX  2 12 1200747602024V0002010040 
B  UNL  REAS  PRIM  1110701748301034V0050050041 
B  UNL  REAS  SEC  PFX  2060600747602024V0002010042 
B  UNL  REAS  SEC  1050101748301034V0050050043 
B  FOLLOW/R  OUT  2383800272601024V0002010044 
B  PROC  PROVl  (A)  347470007070011  H0001010045 
B  PROC  PROVl  (B)  347470010160111  H0007070046 
B  PROC  PROVl  (C)  347470018210111  H0004040047 
B  PROC  PROVl  (D)  335350008100111  H0003030048 
B  PROC  PROVl  (E)  335350012130111  H0002020049 
B  PROC  PROVl  (F)  335350015190111  H0005050050 
B  PROC  PROVl  (G)  323230008100111  H0003030051 


B 

PROC 

PROVl 

(H) 

323230012140111 

H0003030052 

B 

PROC 

PROVl 

(I) 

323230016160011 

H0001010053 

B 

PROC 

PROV2 

(A) 

346460007070011 

H0001010054 

B 

PROC 

PROV2 

(B) 

346460010160111 

H0007070055 

B 

PROC 

PROV2 

(C) 

346460018210111 

H0004040056 

B 

PROC 

PROV2 

(D) 

334340008100111 

H0003030057 

B 

PROC 

PROV2 

(E) 

334340012130111 

H0002020058 

B 

PROC 

PROV2 

(F) 

334340015190111 

H0005050059 

B 

PROC 

PROV2 

(G) 

322220008100111 

H0003030060 

B 

PROC 

PROV2 

(H) 

322220012140111 

H0003030061 

B 

PROC 

PROV2 

(I) 

322220016160011 

H0001010062 

B 

DXl 

COLl 

(A) 

247470031340109 

V0004000063 

B 

DXl 

COLl 

(B) 

247470036400109 

V0005000064 

B 

DXl 

COLl 

(C) 

247470042430109 

V0002000065 

B 

DXl 

COLl 

(D) 

247470045490109 

V0005000066 

B 

DXl 

COLl 

(E) 

247470052630109 

V0012000067 

B 

DXl 

COLl 

(F) 

2474700656901024V0005020068 

B 

DXl 

COL2 

(A) 

235350029380109 

V0010000069 

B 

DXl 

COL2 

(B) 

235350041450109 

V0005000070 

B 

DXl 

COL2 

(C) 

235350047630109 

V0017000071 

B 

DXl 

COL2 

(D) 

235350067690109 

V0003000072 

B 

DXl 

COL2 

(E) 

2353500717501024V0005020073 

B 

DXl 

COL3 

(A) 

223230029320109 

V0004000074 

B 

DXl 

COL3 

(B) 

223230034350109 

V0002000075 

B 

DXl 

COL3 

(C) 

223230037390109 

V0003000076 

B 

DXl 

COL3 

(D) 

223230042440109 

V0003000077 

B 

DXl 

COL3 

(E) 

223230046540109 

V0009000078 

B 

DXl 

COL3 

(F) 

223230056680109 

V0013000079 

B 

DXl 

COL3 

(G) 

223230070730109 

V0004000080 

B 

DXl 

COL3 

(H) 

2232300757500024V0001020081 

B 

DX2 

(A) 

346460031340111 

H0004040082 

B 

DX2 

(B) 

346460036400111 

H0005050083 

B 

DX2 

(C) 

346460042430111 

H0002020084 

B 

DX2 

(D) 

346460045490111 

H0005050085 

B 

DX2 

(E) 

346460052630111 

H0012120086 

B 

DX2 

(F) 

346460065690111 

H0005050087 

B 

DX2 

(G) 

334340029380111 

H0010100088 

B 

DX2 

(H) 

334340041450111 

H0005050089 

B 

DX2 

(I) 

334340047630111 

H0017170090 

B 

DX2 

(J) 

334340067690111 

H0003030091 

B 

DX2 

(K) 

334340071750111 

H0005050092 

B 

DX2 

(L) 

322220029320111 

H0004040093 

B 

DX2 

(M) 

322220034350111 

H0002020094 

B 

DX2 

(N) 

322220037390111 

H0003030095 

B 

DX2 

(0) 

322220042440111 

H0003030096 

B 

DX2 

(P) 

322220046540111 

H0009090097 

B 

DX2 

(Q) 

322220056680111 

H0013130098 

B 

DX2 

(R) 

322220070730111 

H0004040099 

//EOF0512 
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500  GENERAL  SURGERY 


SCAN500.FIL 


H03830247NY0051GENERAL  SURGERY 
H010244 


B 

B 

B 

B 

F 

B 

B 

B 

B 

B 

B 

B 

B 

B 

B 

B 

B 

B 

B 


* 
* 

739160104040011  H0024080001 
2 0909007062 02 024V0005010002 
0080800716001024V0012010003 
00706017 14501024V0054020004 
801  010005 

2434300574601014V0012 020006 
1454500555201014V0004010007 
1444400554601014V0010010003 
044440033200109  V0014000009 
0434300322001014V0013010010 
1423901332401014V0040040011 
1332501554601014V0090090012 
1373601554601014V002 0020013 
2141400544601024V0009010014 
2373700351401014V0022020015 
029290033200109  V0014000016 
0282800322001024V0013010017 
1272401332401024V0040040018 
2313100351401024V0022020019 
230300011090109  V0003000020 
2272501080800024H0003010021 
2171700717OO1024V00C2010022 
217170063610109  V0003000023 
2141201606000024H0003010024 
2040400706002024V0006010025 
0030300716001024V0012010026 
0020101714501024V0054020027 
217170032320011  V0001010028 
2202000241410024V0002010029 
2191900222001024V0003010030 
2191900181501024V0004010031 
805  050032 

306060022140111  H0009090033 
320200009070111  H0003030034 
208080006060011  V0001010035 
1110701071601024V0050050036 
202020006060011  V0001010037 
1050101071601024V0050050038 
223230023230011  V0001010039 
BUNL  REAS  PRIM  PFX  2121200747602024V0002010040 
B  UNL  REAS  PRIM  1110701748301034V0050050041 
B  UNL  REAS  SEC  PFX  2060600747602024V0002010042 


LITHO 
UCA  PFX 
UCA  CODE  1 
UCA  CODE  2 
OTHER  UCA 
DATE  (MO) 
DATE  (DY)1 
DATE  (DY)2 
PROVl  PFXl 
PROVl  PFX2 
PROVl  CODE 
SSN 
FMP 

VISIT  COUNT 
PROVl  TIME 
PROV2  PFXl 
PROV2  PFX2 
PROV2  CODE 
PROV2  TIME 
BREASON  FOR  #2  (1) 
BREASON  FOR  #2  (2) 
B  IF  NOT  SCHED 
BIF  NOT  CLINIC  (1) 
BIF  NOT  CLINIC  (2) 


REF  CODE  PFX 
REF  CODE  1 
REF  CODE  2 
JOB  RELATED 
MIL  ONLY  DUTY 
MIL  ONLY  QTRS 
MIL  ONLY  PROF 
FILLER 

SPEC  PRE  CLIN 
NOT  AVAILABLE 
BPROV2  ADDLl  (YES) 
B  ADDL  PROCl 
BPROV2  ADDL2  (YES) 
B  ADDL  PROC2 
B  ADMITTED 


B  UNL  REAS  SEC 
B  FOLLOW/R  OUT 
B  PROC  PROVl  (A) 
B  PROC  PROVl  (B) 
B  PROC  PROVl  (C) 
B  PROC  PROVl  (D) 
B  PROC  PROVl  (E) 
B  PROC  PROVl  (F) 
B  PROC  PROVl  (G) 


105010174 830103 4V0050050043 
2383800272601024V0002010044 
347470008180111  H0011110045 
347470021240111  H0004040046 
335350009100111  H0002020047 
335350013140111  H0002020048 
335350017210111  H0005050049 
323230008110111  H0004040050 
323230014210111  H0008080051 
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B 

PROC 

PROV2 

(A) 

346460008180111 

H0011110052 

B 

PROC 

PROV2 

(B) 

346460021240111 

H0004040053 

B 

PROC 

PROV2 

(C) 

334340009100111 

H0002020054 

B 

PROC 

PROV2 

(D) 

334340013140111 

H0002020055 

B 

PROC 

PROV2 

(E) 

334340017210111 

H0005050056 

B 

PROC 

PROV2 

(F) 

322220008110111 

H0004040057 

B 

PROC 

PROV2 

(G) 

322220014210111 

H0008080058 

B 

DXl 

COLl 

(A) 

247470031430109 

V0013000059 

B 

DXl 

COLl 

(B) 

247470046520109 

V0007000060 

B 

DXl 

COLl 

(C) 

2474700566101024V0006020061 

B 

DXl 

COL2 

(A) 

235350029300109 

V0002000062 

B 

DXl 

COL2 

(B) 

235350032340109 

V0003000063 

B 

DXl 

COL2 

(C) 

235350036420109 

V0007000064 

B 

DXl 

COL2 

(D) 

235350045500109 

V0006000065 

B 

DXl 

COL2 

(E) 

235350053540109 

V0002000066 

B 

DXl 

COL2 

(F) 

2353500567001024V0015020067 

B 

DXl 

COL3 

(A) 

223230030370109 

V0008000068 

B 

DXl 

COL3 

(B) 

223230039410109 

V0003000069 

B 

DXl 

COL3 

(C) 

223230043480109 

V0006000070 

B 

DXl 

COL3 

(D) 

223230050560109 

V0007000071 

B 

DXl 

COL3 

(E) 

223230059620109 

V0004000072 

B 

DXl 

COL3 

(F) 

223230065670109 

V0003000073 

B 

DXl 

COL3 

(G) 

223230069700109 

V0002000074 

B 

DXl 

COL3 

(H) 

223230072730109 

V0002000075 

B 

DXl 

COL3 

(I) 

2232300758101024V0007020076 

B 

DXl 

COL4 

(A) 

211110029310109 

V0003000077 

B 

DXl 

COL4 

(B) 

211110033410109 

V0009000078 

B 

DXl 

COL4 

(C) 

211110043470109 

V0005000079 

B 

DXl 

COL4 

(D) 

211110049500109 

V0002000080 

B 

DXl 

COL4 

(E) 

211110052520009 

V0001000081 

B 

DXl 

COL4 

(F) 

211110054540009 

V0001000082 

B 

DXl 

COL4 

(G) 

2111100565600024V0001020083 

B 

DX2 

(A) 

346460031430111 

H0013130084 

B 

DX2 

(B) 

346460046520111 

H0007070085 

B 

DX2 

(C) 

346460056610111 

H0006060086 

B 

DX2 

(D) 

334340029300111 

H0002020087 

B 

DX2 

(E) 

334340032340111 

H0003030088 

B 

DX2 

(F) 

334340036420111 

H0007070089 

B 

DX2 

(G) 

334340045500111 

H0006060090 

B 

DX2 

(H) 

334340053540111 

H0002020091 

B 

DX2 

(I) 

334340056700111 

H0015150092 

B 

DX2 

(J) 

322220030370111 

H0008080093 

B 

DX2 

(K) 

322220039410111 

H0003030094 

B 

DX2 

(L) 

322220043480111 

H0006060095 

B 

DX2 

(M) 

322220050560111 

H0007070096 

B 

DX2 

(N) 

322220059620111 

H0004040097 

B 

DX2 

(0) 

322220065670111 

H0003030098 

B 

DX2 

(P) 

322220069700111 

H0002020099 

B 

DX2 

(Q) 

322220072730111 

H0002020100 

B 

DX2 

(R) 

322220075810111 

H0007070101 

B 

DX2 

(S) 

310100029310111 

H0003030102 

B 

DX2 

(T) 

310100033410111 

H0009090103 

B 

DX2 

(U) 

310100043470111 

H0005050104 

B 

DX2 

(V) 

310100049500111 

H0002020105 

B 

DX2 

(W) 

310100052520011 

H0001010106 
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B  DX2  (X)  310100054540011  H0001010107 

//EOF0541 
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510  GYNECOLOGY 


SCAN510.FIL 


H03830247NY0051GYNECOLOGY  * 
H010225  * 
B  LITHO  739160104040011  H0024080001 
B  UCA  PFX  2090900706202024V0005010002 
B  UCA  CODE  1  0080800716001024V0012010003 
B  UCA  CODE  2  0070601714501024V0054020004 
B  OTHER  UCA  1  217170081800109  V0002000005 
B  OTHER  UCA  2  2121200818100024V0001010006 
B  DATE  (MO)  2434300574601014V0012020007 
B  DATE  (DY)1  1454500555201014V0004010008 
B  DATE  (DY)2  1444400554601014V0010010009 
B  PROVl  PFXl  044440033200109  V0014000010 
B  PROVl  PFX2  0434300322001014V0013010011 
B  PROVl  CODE  1423901332401014V0040040012 
B  SSN  1332501554601014V0090090013 
B  FMP  1373601554601014V0020020014 
B  VISIT  COUNT  2141400544601024V0009010015 
B  PROVl  TIME  2373700351401014V0022020016 
B  PROV2  PFXl  029290033200109  V0014000017 
B  PROV2  PFX2  0282800322001024V0013010018 
B  PROV2  CODE  1272401332401024V0040040019 
B  PROV2  TIME  23 13100351401024V0022020020 
BREASON  FOR  #2  (1)  230300011090109  V0003000021 
BREASON  FOR  #2  (2)  2272501080800024H0003010022 
B  IF  NOT  SCHED  2171700717001024V0002010023 
BIF  NOT  CLINIC  (1)  217170063610109  V0003000024 
BIF  NOT  CLINIC  (2)  2141201606000024H0003010025 
B  REF  CODE  PFX  2040400706002024V0006010026 
B  REF  CODE  1  0030300716001024V0012010027 
B  REF  CODE  2  0020101714501024V0054020028 
B  JOB  RELATED  217170032320011  V0001010029 
B  MIL  ONLY  DUTY  2202000241410024V0002010030 
B  MIL  ONLY  QTRS  2191900222001024V0003010031 
B  MIL  ONLY  PROF  2191900181501024V0004010032 
F  FILLER  805  050033 
B  SPEC  PRE  CLIN  306060022140111  H0009090034 
B  NOT  AVAILABLE  320200009070111  H0003030035 
BPROV2  ADDLl  (YES)  208080006060011  V0001010036 
B  ADDL  PROCl  1110701071601024V0050050037 
BPROV2  ADDL2  (YES)  202020006060011  V0001010038 
B  ADDL  PROC2  1050101071601024V0050050039 
B  ADMITTED  211110024240011  V0001010040 
BUNL  REAS  PRIM  PFX  2121200747602024V0002010041 
B  UNL  REAS  PRIM  1110701748301034V0050050042 
B  UNL  REAS  SEC  PFX  2060600747602024V0002010043 
B  UNL  REAS  SEC  1050101748301034V0050050044 
B  FOLLOW/R  OUT  2383800272601024V0002010045 
B  PROC  PROVl  (A)  347470007240111  H0018180046 
B  PROC  PROVl  (B)  335350007090111  H0003030047 
B  PROC  PROVl  (C)  335350011240111  H0014140048 
B  PROC  PROVl  (D)  323230007240111  H0018180049 
B  PROC  PROVl  (E)  311110019230111  H0005050050 
B  PROC  PROV?  (A)  346460007240111  H0018180051 
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B  PROC  PROV2  (B) 
B  PROC  PROV2  (C) 
B  PROC  PROV2  (D) 
B  PROC  PROV2  (E) 


334340007090111  H0003030052 
334340011240111  H0014140053 
322220007240111  H0018180054 
310100019230111  H0005050055 


BDXl 

COLl 

(A) 

247470031330109 

V0003000056 

BDXl 

COLl 

(B) 

247470035410109 

V0007000057 

BDXl 

COLl 

(C) 

247470044570109 

V0014000058 

BDXl 

COLl 

(D) 

247470059630109 

V0005000059 

BDXl 

COLl 

(E) 

247470066720109 

V0007000060 

BDXl 

COLl 

(F) 

247470075800109 

V0006000061 

BDXl 

COLl 

(G) 

2474700828301024V0002020062 

BDXl 

COL2 

(A) 

235350029300109 

V0002000063 

BDXl 

COL2 

(B) 

235350033380109 

V0006000064 

BDXl 

COL2 

(C) 

235350041490109 

V0009000065 

BDXl 

COL2 

(D) 

235350052520009 

V0001000066 

BDXl 

COL2 

(E) 

235350054560109 

V0003000067 

BDXl 

COL2 

(F) 

235350059660109 

V0008000068 

BDXl 

COL2 

(G) 

2353500698301024V0015020069 

BDXl 

COL3 

(A) 

223230028290109 

V0002000070 

BDXl 

COL3 

(B) 

223230032430109 

V0012000071 

BDXl 

COL3 

(C) 

223230046550109 

V0010000072 

BDXl 

COL3 

(D) 

223230058600109 

V0003000073 

BDXl 

COL3 

(E) 

223230062680109 

V0007000074 

BDXl 

COL3 

(F) 

223230071750109 

V0005000075 

BDXl 

COL3 

(G) 

2232300778301024V0007020076 

BDXl 

COL4 

(A) 

211110028300109 

V0003000077 

BDXl 

COL4 

(B) 

211110033370109 

V0005000078 

BDXl 

COL4 

(C) 

211110040430109 

V0004000079 

BDXl 

COL4 

(D) 

211110046480109 

V0003000080 

BDXl 

COL4 

(E) 

211110051650109 

V0015000081 

BDXl 

COL4 

(F) 

2111100676801024V0002020082 

B 

DX2 

(A) 

346460031330111 

H0003030083 

B 

DX2 

(B) 

346460035410111 

H0007070084 

B 

DX2 

(C) 

346460044570111 

H0014140085 

B 

DX2 

(D) 

346460059630111 

H0005050086 

B 

DX2 

(E) 

346460066720111 

H0007070087 

B 

DX2 

(F) 

346460075800111 

H0006060088 

B 

DX2 

(G) 

346460082830111 

H0002020089 

B 

DX2 

(H) 

334340029300111 

H0002020090 

B 

DX2 

(I) 

334340033380111 

H0006060091 

B 

DX2 

(J) 

334340041490111 

H0009090092 

B 

DX2 

(K) 

334340052520011 

H0001010093 

B 

DX2 

(L) 

334340054560111 

H0003030094 

B 

DX2 

(M) 

334340059660111 

H0008080095 

B 

DX2 

(N) 

334340069830111 

H0015150096 

B 

DX2 

(0) 

322220028290111 

H0002020097 

B 

DX2 

(P) 

322220032430111 

H0012120098 

B 

DX2 

(Q) 

322220046550111 

H0010100099 

B 

DX2 

(R) 

322220058600111 

H0003030100 

B 

DX2 

(S) 

322220062680111 

H0007070101 

B 

DX2 

(T) 

322220071750111 

H0005050102 

B 

DX2 

(U) 

322220077830111 

H0007070103 

B 

DX2 

(V) 

310100028300111 

H0003030104 

B 

DX2 

(W) 

310100033370111 

H0005050105 

B 

DX2 

(X) 

310100040430111 

H0004040106 
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PQ  PQ 


DX2  (Y)  310100046480111  H0003030107 

DX2  (Z)  310100051650111  H0015150108 

//EOF0627 
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520  INFECTIOUS  DISEASES 


SCAN520.FIL 


H03830247NY0051INFECTIOUS  DISEASES  * 

H010245  * 

B  LITHO  739160104040011  H0024080001 

B  UCA  PFX  2090900706202024V0005010002 

B  UCA  CODE  1  0080800716001024V0012010003 

B  UCA  CODE  2  0070601714501024V0054020004 

F  OTHER  UCA  801  010005 

B  DATE  (MO)  2434300574601014V0012020006 

B  DATE  (DY)1  1454500555201014V0004010007 

B  DATE  (DY)2  1444400554601014V0010010008 

B  PROVl  PFXl  044440033200109  V0014000009 

B  PROVl  PFX2  0434300322001014V0013010010 

B  PROVl  CODE  1423901332401014V0040040011 

B  SSN  1332501554601014V0090090012 

B  FMP  1373601554601014V0020020013 

B  VISIT  COUNT  2141400544601024V0009010014 

B  PROVl  TIME  2373700351401014V0022020015 

B  PROV2  PFXl  029290033200109  V0014000016 

B  PROV2  PFX2  0282800322001024V0013010017 

B  PROV2  CODE  1272401332401024V0040040018 

B  PROV2  TIME  23 13100351401024V0022020019 

BREASON  FOR  #2  (1)  230300011090109  V0003000020 

BREASON  FOR  #2  (2)  2272501080800024H0003010021 

B  IF  NOT  SCHED  2T71700717001024V0002010022 

BIF  NOT  CLINIC  (1)  217170063610109  V0003000023 

BIF  NOT  CLINIC  (2)  2141201606000024H0003010024 

B  REF  CODE  PFX  2040400706002024V0006010025 

B  REF  CODE  1  0030300716001024V0012010026 

B  REF  CODE  2  0020101714501024V0054020027 

B  JOB  RELATED  217170032320011  V0001010028 

B  MIL  ONLY  DUTY  2202000241410024V0002010029 

B  MIL  ONLY  QTRS  2191900222001024V0003010030 

B  MIL  ONLY  PROF  2191900181501024V0004010031 

F  FILLER  805  050032 

B  SPEC  PRE  CLIN  306060022140111  H0009090033 

B  NOT  AVAILABLE  320200009070111  H0003030034 

BPROV2  ADDLl  (YES)  208080006060011  V0001010035 
B  ADDL  PROCl  1110701071601024V0050050036 

BPROV2  ADDL2  (YES)  202020006060011  V0001010037 
B  ADDL  PROC2  1050101071601024V0050050038 

B  ADMITTED  223230017170011  V0001010039 

BUNL  REAS  PRIM  PFX  2121200747602024V0002010040 
B  UNL  REAS  PRIM  1110701748301034V0050050041 

B  UNL  REAS  SEC  PFX  2060600747602024V0002010042 
B  UNL  REAS  SEC  1050101748301034V0050050043 

B  FOLLOW/R  OUT  2383800272601024V0002010044 

B  PROC  PROVl  (A)  347470008100111  H0003030045 

B  PROC  PROVl  (B)  347470012130111  H0002020046 

B  PROC  PROVl  (C)  335350008120111  H0005050047 

B  PROC  PROVl  (D)  323230008140111  H0007070048 

B  PROC  PROV2  (A)  346460008100111  H0003030049 

B  PROC  PROV2  (B)  346460012130111  H0002020050 

B  PROC  PROV2  (C)  334340008120111  H0005050051 
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'I 


B  PROC  PROV2  (D) 

322220008140111 

H0007070052 

BDXl 

COLl 

(A) 

247470031340109 

V0004000053 

BDXl 

COLl 

(B) 

247470036370109 

V0002000054 

BDXl 

COLl 

(C) 

247470039460109 

V0008000055 

BDXl 

COLl 

(D) 

247470048540109 

V0007000056 

BDXl 

COLl 

(E) 

2474700566401024V0009020057 

BDXl 

COL2 

(A) 

235350029310109 

V0003000058 

BDXl 

COL2 

(B) 

235350033360109 

V0004000059 

BDXl 

COL2 

(C) 

235350038410109 

V0004000060 

BDXl 

COL2 

(D) 

235350043470109 

V0005000061 

BDXl 

COL2 

(E) 

2353500495601024V0008020062 

BDXl 

COL3 

(A) 

223230029310109 

V0003000063 

BDXl 

COL3 

(B) 

223230033370109 

V0005000064 

BDXl 

COL3 

(C) 

223230039440109 

V0006000065 

BDXl 

COL3 

(D) 

223230046460009 

V0001000066 

BDXl 

COL3 

(E) 

223230048500109 

V0003000067 

BDXl 

COL3 

(F) 

2232300525200024V0001020068 

B 

DX2 

(A) 

346460031340111 

H0004040069 

B 

DX2 

(B) 

346460036370111 

H0002020070 

B 

DX2 

(C) 

346460039460111 

H0008080071 

B 

DX2 

(D) 

346460048540111 

H0007070072 

B 

DX2 

(E) 

346460056640111 

H0009090073 

B 

DX2 

(F) 

334340029310111 

H0003030074 

B 

DX2 

(G) 

334340033360111 

H0004040075 

B 

DX2 

(H) 

334340038410111 

H0004040076 

B 

DX2 

(I) 

334340043470111 

H0005050077 

B 

DX2 

(J) 

334340049560111 

H0008080078 

B 

DX2 

(K) 

322220029310111 

H0003030079 

B 

DX2 

(L) 

322220033370111 

H0005050080 

B 

DX2 

(M) 

322220039440111 

H0006060081 

B 

DX2 

(N) 

322220046460011 

H0001010082 

B 

DX2 

(0) 

322220048500111 

H0003030083 

//EOF0451 
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530  INTERNAL  MEDICINE 


SCAN530.FIL 


H03830247NY0051INTERNAL  MEDICINE  * 
H010239  * 
B  LITHO  739160104040011  H0024080001 
B  UCA  PFX  2090900706202024V0005010002 
B  UCA  CODE  1  0080800716001024V0012010003 
B  UCA  CODE  2  0070601714501024V0054020004 
B  OTHER  UCA  2171205818100024H0002010005 
B  DATE  (MO)  2434300574601014V0012020006 
B  DATE  (DY)1  1454500555201014V0004010007 
B  DATE  (DY)2  1444400554601014V0010010008 
B  PROVl  PFXl  044440033200109  V0014000009 
B  PROVl  PFX2  0434300322001014V0013010010 
B  PROVl  CODE  1423901332401014V0040040011 
B  SSN  1332501554601014V0090090012 
B  FMP  1373601554601014V0020020013 
B  VISIT  COUNT  2141400544601024V0009010014 
B  PROVl  TIME  2373700351401014V0022020015 
B  PROV2  PFXl  029290033200109  V0014000016 
B  PROV2  PFX2  0282800322001024V0013010017 
B  PROV2  CODE  1272401332401024V0040040018 
B  PROV2  TIME  2313100351401024V0022020019 
BREASON  FOR  #2  (1)  230300011090109  V0003000020 
BREASON  FOR  #2  (2)  2272501080800024H0003010021 
B  IF  NOT  SCHED  2171700717001024V0002010022 
BIF  NOT  CLINIC  (1)  217170063610109  V0003000023 
BIF  NOT  CLINIC  (2)  2i41201606000024H0003010024 
B  REF  CODE  PFX  2040400706002024V0006010025 
B  REF  CODE  1  0030300716001024V0012010026 
B  REF  CODE  2  0020101714501024V0054020027 
B  JOB  RELATED  217170032320011  V0001010028 
B  MIL  ONLY  DUTY  2202000241410024V0002010029 
B  MIL  ONLY  QTRS  2191900222001024V0003010030 
B  MIL  ONLY  PROF  2191900181501024V0004010031 
F  FILLER  805  050032 
B  SPEC  PRE  CLIN  306060022140111  H0009090033 
B  NOT  AVAILABLE  320200009070111  H0003030034 
BPROV2  ADDLl  (YES)  208080006060011  V0001010035 
B  ADDL  PROCl  1110701071601024V0050050036 
BPROV2  ADDL2  (YES)  202020006060011  V0001010037 
B  ADDL  PROC2  1050101071601024V0050050038 
B  ADMITTED  247470021210011  V0001010039 
BUNL  REAS  PRIM  PFX  2 121200747602024V0002010040 
B  UNL  REAS  PRIM  1110701748301034V0050050041 
B  UNL  REAS  SEC  PFX  2060600747602024V0002010042 
B  UNL  REAS  SEC  1050101748301034V0050050043 
B  FOLLOW/R  OUT  2383800272601024V0002010044 
B  PROC  PROVl  347470007190111  H0013130045 
B  PROC  PROV2  346460007190111  H0013130046 
B  DXl  COLl  (A)  247470031360109  V0006000047 
B  DXl  COLl  (B)  247470039490109  V0011000048 
B  DXl  COLl  (C)  247470052540109  V0003000049 
E  DXl  COLl  (D)  2474700576101024V0005020050 
B  DXl  COL2  (A)  235350029370109  V0009000051 
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DXl  COL2  (B) 
DXl  COL3  (A) 
DXl  COL3  (B) 
DXl  COL3  (C) 
DXl  COL3  (D) 
DXl  COL4  (A) 
DXl  COL4  (B) 
DXl  COL4  (C) 
DXl  COL4  (D) 
DXl  COL4  (E) 
DXl  COL4  (F) 


DX2 

(A) 

DX2 

(B) 

DX2 

(C) 

DX2 

(D) 

DX2 

(E) 

DX2 

(F) 

DX2 

(G) 

DX2 

(H) 

DX2 

(I) 

DX2 

(J) 

DX2 

(K) 

DX2 

(L) 

DX2 

(M) 

DX2 

(N) 

DX2 

(0) 

//EOF0449 


2353500405701024V0018020052 
223230029350109  V0007000053 
223230038410109  V0004000054 
223230044450109  V0002000055 
2232300485201024V0005020056 
211110029290009  V0001000057 
211110031310009  V0001000058 
211110033340109  V0002000059 
211110037390109  V0003000060 
211110042420009  V0001000061 
2111100444501024V0002020062 
346460031360111  H0006060063 
346460039490111  H0011110064 
346460052540111  H0003030065 
346460057610111  H0005050066 
334340029370111  H0009090067 
334340040570111  H0018180068 
322220029350111  H0007070069 
322220038410111  H0004040070 
322220044450111  H0002020071 
322220048520111  H0005050072 
310100029290011  H0001010073 
310100031310011  H0001010074 
310100033340111  H0002020075 
310100037390111  H0003030076 
310100042420011  H0001010077 
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540  NEPHROLOGY/DIALYSIS 


SCAN540.FIL 


H03830247NY0051NEPHROIiOGY/DIALYSIS  * 
H010217  * 
B  LITHO  739160104040011  H0024080001 
B  UCA  PFX  2090900706202024V0005010002 
B  UCA  CODE  1  0080800716001024V0012010003 
B  UCA  CODE  2  0070601714501024V0054020004 
B  OTHER  UCA  2171700818100024H0001010005 
B  DATE  (MO)  2434300574601014V0012020006 
B  DATE  (DY)1  1454500555201014V0004010007 
B  DATE  (DY)2  1444400554601014V0010010008 
B  PROVl  PFXl  044440033200109  V0014000009 
B  PROVl  PFX2  0434300322001014V0013010010 
B  PROVl  CODE  1423901332401014V0040040011 
B  SSN  1332501554601014V0090090012 
B  FMP  1373601554601014V0020020013 
B  VISIT  COUNT  2141400544601024V0009010014 
B  PROVl  TIME  2373700351401014V0022020015 
B  PROV2  PFXl  029290033200109  V0014000016 
B  PROV2  PFX2  0282800322001024V0013010017 
B  PROV2  CODE  1272401332401024V0040040018 
B  PROV2  TIME  2313100351401024V0022020019 
BREASON  FOR  #2  (1)  230300011090109  V0003000020 
BREASON  FOR  #2  (2)  2272501080800024H0003010021 
B  IF  NOT  SCHED  2171700717001024V0002010022 
BIF  NOT  CLINIC  (1)  217170063610109  V0003000023 
BIF  NOT  CLINIC  (2)  2141201606000024H0003010024 
B  REF  CODE  PFX  2040400706002024V0006010025 
B  REF  CODE  1  0030300716001024V0012010026 
B  REF  CODE  2  0020101714501024V0054020027 
B  JOB  RELATED  217170032320011  V0001010028 
B  MIL  ONLY  DUTY  2202000241410024V0002010029 
B  MIL  ONLY  QTRS  2191900222001024V0003010030 
B  MIL  ONLY  PROF  2191900181501024V0004010031 
F  FILLER  805  050032 
B  SPEC  PRE  CLIN  306060022140111  H0009090033 
B  NOT  AVAILABLE  320200009070111  H0003030034 
BPROV2  ADDLl  (YES)  208080006060011  V0001010035 
B  ADDL  PROCl  1110701071601024V0050050036 
BPROV2  ADDL2  (YES)  202020006060011  V0001010037 
B  ADDL  PROC2  1050101071601024V0050050038 
B  ADMITTED  247470027270011  V0001010039 
BUNL  REAS  PRIM  PFX  2121200747602024V0002010040 
B  UNL  REAS  PRIM  1110701748301034V0050050041 
B  UNL  REAS  SEC  PFX  2060600747602024V0002010042 
B  UNL  REAS  SEC  1050101748301034V0050050043 
B  FOLLOW/R  OUT  2383800393801024V0002010044 


B 

PROC 

PROVl 

(A) 

347470008100111 

H0003030045 

B 

PROC 

PROVl 

(B) 

347470012150111 

H0004040046 

B 

PROC 

PROVl 

(C) 

347470017190111 

H0003030047 

B 

PROC 

PROVl 

(D) 

347470021250111 

H0005050048 

B 

PROC 

PROVl 

(E) 

335350009090011 

H0001010049 

B 

PROC 

PROVl 

(F) 

335350011130111 

H0003030050 

B 

PROC 

PROVl 

(G) 

335350015160111 

H0002020051 

A 


4 
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B  PROC  PROVl  (H) 

B  PROC  PROVl  (I) 

B  PROC  PROVl  (J) 

B  PROC  PROVl  (K) 

B  PROC  PROVl  (L) 

B  PROC  PROVl  (M) 

B  PROC  PROVl  (N) 

B  PROC  PROVl  (O) 

B  PROC  PROVl  (P) 

B  PROC  PROVl  (Q) 

B  PROC  PROVl  (R) 

B  PROC  PROVl  (S) 

B  PROC  PROVl  (T) 

B  PROC  PROV2  (A) 

B  PROC  PROV2  (B) 

B  PROC  PROV2  (C) 

B  PROC  PROV2  (D) 

B  PROC  PROV2  (E) 

B  PROC  PROV2  (F) 

B  PROC  PROV2  (G) 

B  PROC  PROV2  (H) 

B  PROC  PROV2  (I) 

B  PROC  PROV2  (J) 

B  PROC  PROV2  (K) 

B  PROC  PROV2  (L) 

B  PROC  PROV2  (M) 

B  PROC  PROV2  (N) 

B  PROC  PROV2  (0) 

B  PROC  PR0V2  (P) 

B  PROC  PR0V2  (Q) 

B  PROC  PR0V2  (R) 

B  PROC  PR0V2  (S) 

B  PROC  PR0V2  (T) 

B  OTHER  CODES  (A) 
B  OTHER  CODES  (B) 
B  DXl  COLl  (A) 

B  DXl  COLl  (B) 

B  DXl  COLl  (C) 

B  DXl  COLl  (D) 

B  DXl  COLl  (E) 

B  DXl  COLl  (F) 

B  DXl  C0L2  (A) 

B  DXl  C0L2  (B) 

B  DXl  C0L2  (C) 

B  DXl  C0L2  (D) 

B  DXl  C0L2  (E) 

B  DXl  C0L2  (F) 

B  DXl  C0L2  (G) 

B  DXl  C0L3  (A) 

B  DXl  C0L3  (B) 

B  DXl  C0L3  (C) 

B  DXl  C0L3  (D) 

B  DXl  C0L3  (E) 

B  DXl  COL4  (A) 

B  DXl  C0L4  (B) 


335350018210111  H0004040052 
335350024250111  H0002020053 
335350027280111  H0002020054 
335350030310111  H0002020055 
335350033340111  H0002020056 
323230009190111  H0011110057 
323230021210011  H0001010058 
323230023240111  H0002020059 
3232300263201D 1  H0007070060 
311110021230111  H0003030061 
311110025280111  H0004040062 
311110030300011  H0001010063 
311110032330111  H0002020064 
346460008100111  H0003030065 
346460012150111  H0004040066 
346460017190111  H0003030067 
346460021250111  H0005050068 
334340009090011  H0001010069 
334340011130111  H0003030070 
334340015160111  H0002020071 
334340018210111  H0004040072 
334340024250111  H0002020073 
334340027280111  H0002020074 
334340030310111  H0002020075 
334340033340111  H0002020076 
322220009190111  H0011110077 
322220021210011  H0001010078 
322220023240111  H0002020079 
322220026320111  H0007070080 
310100021230111  H0003030081 
310100025280111  H0004040082 
310100030300011  H0001010083 
310100032330111  H0002020084 
322220072830111  H0012120085 
318180072830111  H0012120086 
247470044470109  V0004000087 
247470049540109  V0006000088 
247470056580109  V0003000089 
247470060630109  V0004000090 
247470065700109  V0006000091 
2474700727901024V0008020092 
235350041450109  V0005000093 
235350047480109  V0002000094 
235350050550109  V0006000095 
235350057610109  V0005000096 
235350063670109  V0005000097 
235350069760109  V0008000098 
2353500788301024V0006020099 
223230041440109  V0004000100 
223230046470109  V0002000101 
223230050540109  V0005000102 
223230056610109  V0006000103 
2232300636300024V0001020104 
211110041430109  V0003000105 
211110045460109  V0002000106 
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DXl  COL4  (C) 
DXl  COL4  (D) 
DXl  COL4  (E) 
DXl  COL4  (F) 
DXl  COL4  (G) 
DXl  COL4  (H) 
DXl  COL4  (I) 
DX2  (A) 
DX2  (B) 
DX2  (C) 
DX2  (D) 
DX2  (E) 
DX2  (F) 
DX2  (G) 
DX2  (H) 
DX2  (I) 
DX2  (J) 
DX2  (K) 
DX2  (L) 
DX2  (M) 
DX2  (N) 
DX2  (O) 
DX2  (P) 
DX2  (Q) 
DX2  (R) 
DX2  (S) 
DX2  (T) 
DX2  (U) 
DX2  (V) 
DX2  (W) 
DX2  (X) 
DX2  (Y) 
DX2  (Z) 
//EOF0599 


211110048500109  V0003000107 
211110052540109  V0003000108 
211110056560009  V0001000109 
211110058590109  V0002000110 
211110063630009  VOOOlOOOlll 
211110065650009  V0001000112 
2111100686800024V000102011? 
346460044470111  H0004040114 
346460049540111  H0006060115 
346460056580111  H0003030116 
346460060630111  H0004040117 
346460065700111  H0006060118 
346460072790111  H0008080119 
334340041450111  H0005050120 
334340047480111  H0002020121 
334340050550111  H0006060122 
334340057610111  H0005050123 
334340063670111  H0005050124 
334340069760111  H0008080125 
334340078830111  H0006060126 
322220041440111  H0004040127 
322220046470111  H0002020128 
322220050540111  H0005050129 
322220056610111  H0006060130 
322220063630011  H0001010131 
310100041430111  H0003030132 
310100045460111  H0002020133 
310100048500111  H0003030134 
310100052540111  H0003030135 
310100056560011  H0001010136 
310100058590111  H0002020137 
310100063630011  H0001010138 
310100065650011  H0001010139 
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550  NEUROLOGY 


SCAN550.FIL 


H03830247Ny0051NEUROLOGY  * 
H010224  * 
B  LITHO  739160104040011  H0024080001 
B  UCA  PFX  2090900706202024V0005010002 
B  UCA  CODE  1  0080800716001024V0012010003 
B  UCA  CODE  2  0070601714501024V0054020004 
B  OTHER  UCA  2171700818100024V0001010005 
B  DATE  (MO)  2434300574601014V0012020006 
B  DATE  (DY)1  1454500555201014V0004010007 
B  DATE  (DY)2  1444400554601014V0010010008 
B  PROVl  PFXl  044440033200109  V0014000009 
B  PROVl  PFX2  0434300322001014V0013010010 
B  PROVl  CODE  1423901332401014V0040040011 
B  SSN  1332501554601014V0090090012 
B  FMP  1373601554601014V0020020013 
B  VISIT  COUNT  2141400544601024V0009010014 
B  PROVl  TIME  2373700351401014V0022020015 
B  PROV2  PFXl  029290033200109  V0014000016 
B  PROV2  PFX2  0282800322001024V0013010017 
B  PROV2  CODE  1272401332401024V0040040018 
B  PROV2  TIME  2313100351401024V0022020019 
BREASON  FOR  #2  (1)  230300011090109  V0003000020 
BREASON  FOR  #2  (2)  2272501080800024H0003010021 
B  IF  NOT  SCHED  2171700717001024V0002010022 
BIF  NOT  CLINIC  (1)  217170063610109  V0003000023 
BIF  NOT  CLINIC  (2)  2141201606000024H0003010024 
B  REF  CODE  PFX  2040400706002024V0006010025 
B  REF  CODE  1  0030300716001024V0012010026 
B  REF  CODE  2  0020101714501024V0054020027 
B  JOB  RELATED  217170032320011  V0001010028 
B  MIL  ONLY  DUTY  2202000241410024V0002010029 
B  MIL  ONLY  QTRS  2191900222001024V0003010030 
B  MIL  ONLY  PROF  2191900181501024V0004010031 
F  FILLER  805  050032 
B  SPEC  PRE  CLIN  306060022140111  H0009090033 
B  NOT  AVAILABLE  320200009070111  H0003030034 
BPROV2  ADDLl  (YES)  208080006060011  V0001010035 
B  ADDL  PROCl  1110701071601024V0050050036 
BPROV2  ADDL2  (YES)  202020006060011  V0001010037 
B  ADDL  PROC2  1050101071601024V0050050038 
B  ADMITTED  223230012120011  V0001010039 
BUNL  REAS  PRIM  PFX  2121200747602024V0002010040 
B  UNL  REAS  PRIM  1110701748301034V0050050041 
B  UNL  REAS  SEC  PFX  2060600747602024V0002010042 
B  UNL  REAS  SEC  1050101748301034V0050050043 
B  FOLLOW/R  OUT  2383800151401024V0002010044 
B  PROC  PROVl  (A)  347470007120111  H0006060045 
B  PROC  PROVl  (B)  335350007120111  H0006060046 
B  PROC  PROVl  (C)  323230007110111  H0005050047 
B  PROC  PROV2  (A)  346460007120111  H0006060048 
B  PROC  PROV2  (B)  334340007120111  H0006060049 
B  PROC  PROV2  (C)  322220007110111  H0005050050 
L  DXl  COLl  (A)  247470019460109  V0028000051 
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DXl  COLl  (B)  247470049590109  V0011000052 

DXl  COLl  (C)  247470062710109  V0010000053 

DXl  COLl  (D)  2474700748301024V0010020054 

DXl  COL2  (A)  235350016240109  V0009000055 

DXl  COL2  (B)  235350027500109  V0024000056 

DXl  COL2  (C)  235350053590109  V0007000057 

DXl  COL2  (D)  2353500628301024V0022020058 

DXl  COL3  (A)  223230017320109  V0016000059 

DXl  COL3  (B)  223230034430109  V0010000060 

DXl  COL3  (C)  223230046580109  V0013000061 

DXl  COL3  (D)  2232300617101024V0011020062 

DXl  COL4  (A)  211110021310109  V0011000063 

DXl  COL4  (B)  211110034480109  V0015000064 

DXl  COL4  (C)  211110050600109  V0011000065 

DXl  COL4  (D)  211110063640109  V0002000066 

DXl  COL4  (E)  211110066660009  V0001000067 

DXl  COL4  (F)  2111100686800024V0001020068 

DX2  (A)  346460019460111  H0028280069 

DX2  (B)  346460049590111  H0011110070 

DX2  (C)  346460062710111  H0010100071 

DX2  (D)  346460074830111  H0010100072 

DX2  (E)  334340016240111  H0009090073 

DX2  (F)  334340027500111  H0024240074 

DX2  (G)  334340053590111  H0007070075 

DX2  (H)  334340062830111  H0022220076 

DX2  (I)  322220017320111  H0016160077 

DX2  (J)  322220034430111  H0010100078 

DX2  (K)  322220046580111  H0013130079 

DX2  (L)  322220061710111  H0011110080 

DX2  (M)  310100021310111  H0011110081 

DX2  (N)  310100034480111  H0015150082 

DX2  (O)  310100050600111  H0011110083 

DX2  (P)  310100063640111  H0002020084 

DX2  (Q)  310100066660011  H0001010085 

//EOF0590 
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560  NEUROSURGERY 


SCAN560.FIL 


H03830247NY0051NEUROSURGERy  * 
H010236  * 
B  LITHO  739160104040011  H0024080001 
B  UCA  PFX  2090900706202024V0005010002 
B  UCA  CODE  1  0080800716001024V0012010003 
B  UCA  CODE  2  0070601714501024V0054020004 
F  OTHER  UCA  801  010005 
B  DATE  (MO)  2434300574601014V0012020006 
B  DATE  (DY)1  1454500555201014V0004010007 
B  DATE  (DY)2  1444400554601014V0010010008 
B  PROVl  PFXl  044440033200109  V0014000009 
B  PROVl  PFX2  0434300322001014V0013010010 
B  PROVl  CODE  1423901332401014V0040040011 
B  SSN  1332501554601014V0090090012 
B  FMP  1373601554601014V0020020013 
B  VISIT  COUNT  2141400544601024V0009010014 
B  PROVl  TIME  2373700351401014V0022020015 
B  PROV2  PFXl  029290033200109  V0014000016 
B  PROV2  PFX2  0282800322001024V0013010017 
B  PROV2  CODE  1272401332401024V0040040018 
B  PROV2  TIME  2313100351401024V0022020019 
BREASON  FOR  #2  (1)  230300011090109  V0003000020 
BREASON  FOR  #2  (2)  2272501080800024H0003010021 
B  IF  NOT  SCHED  2171700717001024V0002010022 
BIF  NOT  CLINIC  (1)  217170063610109  V0003000023 
BIF  NOT  CLINIC  (2)  2141201606000024H0003010024 
B  REF  CODE  PFX  2040400706002024V0006010025 
B  REF  CODE  1  0030300716001024V0012010026 
B  REF  CODE  2  0020101714501024V0054020027 
B  JOB  RELATED  217170032320011  V0001010028 
B  MIL  ONLY  DUTY  2202000241410024V0002010029 
B  MIL  ONLY  QTRS  2191900222001024V0003010030 
B  MIL  ONLY  PROF  2191900181501024V0004010031 
F  FILLER  805  050032 
B  SPEC  PRE  CLIN  306060022140111  H0009090033 
B  NOT  AVAILABLE  320200009070111  H0003030034 
BPROV2  ADDLl  (YES)  208080006060011  V0001010035 
B  ADDL  PROCl  1110701071601024V0050050036 
BPROV2  ADDL2  (YES)  202020006060011  V0001010037 
B  ADDL  PROC2  1050101071601024V0050050038 
B  ADMITTED  223230014140011  V0001010039 
BUNL  REAS  PRIM  PFX  2121200747602024V0002010040 
B  UNL  REAS  PRIM  1110701748301034V0050050041 
B  UNL  REAS  SEC  PFX  2060600747602024V0002010042 
B  UNL  REAS  SEC  1050101748301034V0050050043 
B  FOLLOW/R  OUT  2383800181701024V0002010044 
B  PROC  PROVl  (A)  347470008130111  H0006060045 
B  PROC  PROVl  (B)  347470015150011  H0001010046 
B  PROC  PROVl  (C)  335350007120111  H0006060047 
B  PROC  PROVl  (D)  335350014150111  H0002020048 
B  PROC  PPOVl  (E)  323230007070011  H0001010049 
B  PROC  !  .<0V1  (F)  323230009120111  H0004040050 
B  PROr  PROV2  (A)  346460008130111  H0006060051 
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PROC 

PROV2 

(B) 

346460015150011 

H0001010052 

PROC 

PROV2 

(C) 

334340007120111 

H0006060053 

PROC 

PROV2 

(D) 

334340014150111 

H0002020054 

PROC 

PROV2 

(E) 

322220007070011 

H0001010055 

PROC 

PROV2 

(F) 

322220009120111 

H0004040056 

OTHER  (M) 

CODES 

311110040680111 

H0029290057 

DXl 

COLl 

(A) 

247470022620109 

V0041000058 

DXl 

COLl 

(B) 

247470064790109 

V0016000059 

DXl 

COLl 

(C) 

2474700818301024V0003020060 

DXl 

COL2 

(A) 

235350017260109 

V0010000061 

DXl 

COL2 

(B) 

235350028490109 

V0022000062 

DXl 

COL2 

(C) 

235350051540109 

V0004000063 

DXl 

COL2 

(D) 

235350056630109 

V0008000064 

DXl 

COL2 

(E) 

235350065710109 

V0007000065 

DXl 

COL2 

(F) 

2353500738301024V0011020066 

DXl 

COL3 

(A) 

223230017230109 

V0007000067 

DXl 

COL3 

(B) 

223230025320109 

V0008000068 

DXl 

COL3 

(C) 

223230034490109 

V0016000069 

DXl 

COL3 

(D) 

223230051630109 

V0013000070 

DXl 

COL3 

(E) 

223230065700109 

V0006000071 

DXl 

COL3 

(F) 

223230072780109 

V0007000072 

DXl 

COL3 

(G) 

2232300808301024V0004020073 

DXl 

COL4 

(A) 

211110017190109 

V0003000074 

DXl 

COL4 

(B) 

211110021260109 

V0006000075 

DXl 

COL4 

(C) 

211110028310109 

V0004000076 

DXl 

COL4 

(D) 

211110033340109 

V0002000077 

DXl 

COL4 

(E) 

2111100363701024V0002020078 

DX2 

(A) 

346460022620111 

H0041410079 

DX2 

(B) 

346460064790111 

H0016160080 

DX2 

(C) 

346460081830111 

H0003030081 

DX2 

(D) 

334340017260111 

H0010100082 

DX2 

(E) 

334340028490111 

H0022220083 

DX2 

(F) 

334340051540111 

H0004040084 

DX2 

(G) 

334340056630111 

H0008080085 

DX2 

(H) 

334340065710111 

H0007070086 

DX2 

(I) 

334340073830111 

H0011110087 

DX2 

(J) 

322220017230111 

H0007070088 

DX2 

(K) 

322220025320111 

H0008080089 

DX2 

(L) 

322220034490111 

H0016160090 

DX2 

(M) 

322220051630111 

H0013130091 

DX2 

(N) 

322220065700111 

H0006060092 

DX2 

(0) 

322220072780111 

H0007070093 

DX2 

(P) 

322220080830111 

H0004040094 

DX2 

(Q) 

310100017190111 

H0003030095 

DX2 

(R) 

310100021260111 

H0006060096 

DX2 

(S) 

310100028310111 

H0004040097 

DX2 

(T) 

310100033340111 

H0002020098 

//EOF0612 
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580  NUTRITION 


SCAN580.FIL 


H02830247NY0051NUTRITION 

H0346 

B  LITHO  73916( 


B  LITHO 

B  UCA  PFX 

B  UCA  CODE  1 

B  UCA  CODE  2 

F  OTHER  UCA 

B  DATE  (MO) 

B  DATE  (DY) 1 

B  DATE  (DY)2 

B  PROVl  PFXl 

B  PROVl  PFX2 

B  PROVl  CODE 

B  SSN 

B  FMP 

B  VISIT  COUNT 

B  PROVl  TIME 

B  PROV2  PFXl 

B  PROV2  PFX2 

B  PROV2  CODE 

B  PROV2  TIME 

BREASON  FOR  #2  (1) 
BREASON  FOR  #2  (2) 
B  IF  NOT  SCHED 
BIF  NOT  CLINIC  (1) 
BIF  NOT  CLINIC  (2) 
B  REF  CODE  PFX 
B  REF  CODE  1 

B  REF  CODE  2 

F  JOB  RELATED 
F  MIL  ONLY  DUTY 

F  MIL  ONLY  QTRS 

F  MIL  ONLY  PROF 

F  FILLER 

B  SPEC  PRE  CLIN 

B  NOT  AVAILABLE 

BPROV2  ADDLl  (YES) 
B  ADDL  PROCl 
BPROV2  ADDL2  (YES) 
B  ADDL  PROC2 
F  ADMITTED 

BUNL  REAS  PRIM  PFX 
B  UNL  REAS  PRIM 

B  UNL  REAS  SEC  PFX 
B  UNL  REAS  SEC 

B  FOLLOW/R  OUT 

B  PROC  PROVl  (A) 

B  PROC  PROVl  (B) 

B  PROC  PROVl  (C) 

B  PROC  PROVl  (D) 

B  PROC  PROVl  (E) 

B  PROC  PROVl  (F) 

B  PROr  PROVl  (G) 


739160104040011  H0024080001 
2090900706202024V0005010002 
0080800716001024V0012010003 
0070601714501024V0054020004 
801  010005 
2434300574601014V0012020006 
1454500555201014V0004010007 
1444400554601014V0010010008 
044440033200109  V0014000009 
0434300322001014V0013010010 
1423901332401014V0040040011 
1332501554601014V0090090012 
1373601554601014V0020020013 
2141400544601024V0009010014 
2373700351401014V0022020015 
029290033200109  V0014000016 
0282800322001024V0013010017 
1272401332401024V0040040018 
2313100351401024V0022020019 
230300011090109  V0003000020 
2272501080800024H0003010021 
2171700717001024V0002010022 
217170063610109  V0003000023 
2141201606000024H0003010024 
2040400706002024V0006010025 
0030300716001024V0012010026 
0020101714501024V0054020027 
801  010028 
801  010029 
801  010030 
801  010031 
805  050032 
306060022140111  H0009090033 
320200009070111  H0003030034 
208080006060011  V0001010035 
1110701071601024V0050050036 
202020006060011  V0001010037 
1050101071601024V0050050038 
801  010039 
2121200747602024V0002010040 
1110701748301034V0050050041 
2060600747602024V0002010042 
1050101748301034V0050050043 
2383800292801024V0002010044 
347470008120111  H0005050045 
347470014160111  H0003030046 
335350008110111  H0004040047 
335350014160111  H0003030048 
335350018220111  H0005050049 
335350024240011  H0001010050 
323230008090111  H0002020051 


-41- 


B  PROC  PROVl  (H)  323230011240111  H0014140052 
B  PROC  PROVl  (I)  311110019190011  H0001010053 
B  PROC  PROV2  (A)  346460008120111  H0005050054 
B  PROC  PROV2  (B)  346460014160111  H0003030055 
B  PROC  PROV2  (C)  334340008110111  H0004040056 
B  PROC  PROV2  (D)  334340014160111  H0003030057 
B  PROC  PROV2  (E)  334340018220111  H0005050058 
B  PROC  PROV2  (F)  334340024240011  H0001010059 
B  PROC  PROV2  (G)  322220008090111  H0002020060 
B  PROC  PROV2  (H)  322220011240111  H0014140061 
B  PROC  PROV2  (I)  310100019190011  H0001010062 
BDXl  COLl  (A)  247470033400109  V0008000063 
BDXl  COLl  (B)  247470043460109  V0004000064 
BDXl  COLl  (C)  247470048540109  V0007000065 
BDXl  COLl  (D)  2474700577901024V0023020066 
BDXl  COL2  (A)  235350031340109  V0004000067 
BDXl  COL2  (B)  235350037420109  V0006000068 
BDXl  COL2  (C)  235350045480109  V0004000069 
BDXl  COL2  (D)  235350050520109  V0003000070 
BDXl  COL2  (E)  235350053630109  V0011000071 
BDXl  COL2  (F)  2353500667801024V0013020072 
BDXl  COL3  (A)  223230031360109  V0006000073 
BDXl  COL3  (B)  223230039450109  V0007000074 
BDXl  COL3  (C)  223230048640109  V0017000075 
BDXl  COL3  (D)  2232300666701024V0002020076 
B  DX2  (A)  346460033400111  H0008080077 
B  DX2  (B)  346460043460111  H0004040078 
B  DX2  (C)  346460048540111  H0007070079 
B  DX2  (D)  346460057790111  H0023230080 
B  DX2  (E)  334340031340111  H0004040081 
B  DX2  (F)  334340037420111  H0006060082 
B  DX2  (G)  334340045480111  H0004040083 
B  DX2  (H)  334340050520111  H0003030084 
B  DX2  (I)  334340056630111  H0008080085 
B  DX2  (J)  334340066780111  H0013130086 
B  DX2  (K)  322220031360111  H0006060087 
B  DX2  (L)  322220039450111  H0007070088 
B  DX2  (M)  322220048640111  H0017170089 
//EOF0529 
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590  OB 


SCAN590.FIL 


H03830247NY00510B  * 
H010233  * 
B  LITHO  739160104040011  H0024080001 
B  UCA  PFX  2090900706202024V0005010002 
B  UCA  CODE  1  0080800716001024V0012010003 
B  UCA  CODE  2  0070601714501024V0054020004 
B  OTHER  UCAl  217170081800109  V0002000005 
B  OTHER  UCA2  2121200818100024H0001010006 
B  DATE  (MO)  2434300574601014V0012020007 
B  DATE  (DY)1  1454500555201014V0004010008 
B  DATE  (DY)2  1444400554601014V0010010009 
B  PROVl  PFXl  044440033200109  V0014000010 
B  PROVl  PFX2  0434300322001014V0013010011 
B  PROVl  CODE  1423901332401014V0040040012 
B  SSN  1332501554601014V0090090013 
B  FMP  1373601554601014V0020020014 
B  VISIT  COUNT  2141400544601024V0009010015 
B  PROVl  TIME  2373700351401014V0022020016 
B  PROV2  PFXl  029290033200109  V0014000017 
B  PROV2  PFX2  0282800322001024V0013010018 
B  PROV2  CODE  1272401332401024V0040040019 
B  PROV2  TIME  2313100351401024V0022020020 
BREASON  FOR  #2  (1)  230300011090109  V0003000021 
BREASON  FOR  #2  (2)  2272501080800024H0003010022 
B  IF  NOT  SCHED  2171700717001024V0002010023 
BIF  NOT  CLINIC  (1)  217170063610109  V0003000024 
BIF  NOT  CLINIC  (2)  2141201606000024H0003010025 
B  REF  CODE  PFX  2040400706002024V0006010026 
B  REF  CODE  1  0030300716001024V0012010027 
B  REF  CODE  2  0020101714501024V0054020028 
B  JOB  RELATED  217170032320011  V0001010029 
B  MIL  ONLY  DUTY  2202000241410024V0002010030 
B  MIL  ONLY  QTRS  2191900222001024V0003010031 
B  MIL  ONLY  PROF  2191900181501024V0004010032 
F  FILLER  805  050033 
B  SPEC  PRE  CLIN  306060022140111  H0009090034 
B  NOT  AVAILABLE  320200009070111  H0003030035 
BPROV2  ADDLl  (YES)  208080006060011  V0001010036 
B  ADDL  PROCl  1110701071601024V0050050037 
BPROV2  ADDL2  (YES)  202020006060011  V0001010038 
B  ADDL  PROC2  1050101071601024V0050050039 
B  ADMITTED  223230023230011  V0001010040 
BUNL  REAS  PRIM  PFX  2121200747602024V0002010041 
B  UNL  REAS  PRIM  1110701748301034V0050050042 
B  UNL  REAS  SEC  PFX  2060600747602024V0002010043 
B  UNL  REAS  SEC  1050101748301034V0050050044 
B  FOLLOW/R  OUT  2383800272601024V0002010045 
B  PROC  PROVl  (A)  347470007080111  H0002020046 
B  PROC  PROVl  (B)  347470010220111  H0013130047 
B  PROC  PROVl  (C)  335350007140111  H0008080048 
B  PROC  PROVl  (D)  335350016220111  H0007070049 
B  PROC  PROVl  (E)  323230007200111  H0014140050 
B  PROC  PROV2  fA)  346460007080111  H0002020051 


-43- 


B 

PROC 

PROV2 

(B) 

B 

PROC 

PROV2 

(C) 

B 

PROC 

PROV2 

(D) 

B 

PROC 

PROV2 

(E) 

BDXl 

COLl 

(A) 

BDXl 

COLl 

(B) 

BDXl 

COLl 

(C) 

BDXl 

COLl 

(D) 

BDXl 

COLl 

(E) 

BDXl 

COLl 

(F) 

BDXl 

COL2 

(A) 

BDXl 

COL2 

(B) 

BDXl 

COL2 

(C) 

BDXl 

COL2 

(D) 

BDXl 

COL2 

(E) 

BDXl 

COL2 

(F) 

BDXl 

COL3 

(G) 

BDXl 

COL4 

(A) 

BDXl 

COL4 

(B) 

BDXl 

COL4 

(C) 

B 

DX2 

(A) 

B 

DX2 

(B) 

B 

DX2 

(C) 

B 

DX2 

(D) 

B 

DX2 

(E) 

B 

DX2 

(F) 

B 

DX2 

(G) 

B 

DX2 

(H) 

B 

DX2 

(I) 

B 

DX2 

(J) 

B 

DX2 

(K) 

B 

DX2 

(L) 

B 

DX2 

(M) 

B 

DX2 

(N) 

B 

DX2 

(0) 

//EOF0526 


346460010220111  H0013130052 
334340007140111  H0008080053 
334340016220111  H0007070054 
322220007200111  H0014140055 
247470031350109  V0005000056 
247470038440109  V0007000057 
247470047490109  V0003000058 
247470052540109  V0003000059 
247470057600109  V0004000060 
2474700636501024V0003020061 
235350029310109  V0003000062 
235350034370109  V0004000063 
235350040430109  V0004000064 
235350046490109  V0004000065 
235350052550109  V0004000066 
2353500586201024V0005020067 
2232300296201024V0034020068 
211110029340109  V0006000069 
211110036390109  yOOO40OOO7O 
2111100424301024V0002020071 
346460031350111  H0005050072 
346460038440111  H0007070073 
346460047490111  H0003030074 
346460052540111  H0003030075 
346460057600111  H0004040076 
346460063650111  H0003030077 
334340029310111  H0003030078 
334340034370111  H0004040079 
334340040430111  H0004040080 
334340046490111  H0004040081 
334340052550111  H0004040082 
334340058620111  H0005050083 
322220029620111  H0034340084 
310100029340111  H0006060085 
310100036390111  H0004040086 


600  ONCOLOGY 


SCAN600.FIL 


H02830247NY0051ONCOLOGY 

H0344 

B  LITHO 

B  UCA  PFX 

B  tICA  CODE  1 

B  UCA  CODE  2 

B  OTHER  UCA  1 

B  OTHER  UCA  2 


B 

DATE 

(MO) 

B 

DATE 

(DY)1 

B 

DATE 

(DY)2 

B 

PROVl 

PFXl 

B 

PROVl 

PFX2 

B 

PROVl 

CODE 

B 

SSN 

B 

FMP 

B 

VISIT 

COUNT 

B 

PROVl 

TIME 

B 

PROV2 

PFXl 

B 

PROV2 

PFX2 

B 

PROV2 

CODE 

B 

PROV2 

TIME 

BREASON  FOR  #2  (1) 
BREASON  FOR  #2  (2) 
B  IF  NOT  SCHED 
BIF  NOT  CLINIC  (1) 
BIF  NOT  CLINIC  (2) 


* 
* 

739160104040011  H0024080001 
2090900706202024V0005010002 
0080800716001024V0012010003 
0070601714501024V0054020004 
217170081800109  V0002000005 
2121200818100024V0001010006 
2434300574601014V0012020007 
1454500555201014V0004010008 
1444400554601014V0010010009 
044440033200109  V0014000010 
0434300322001014V0013010011 
1423901332401014V0040040012 
1332501554601014V0090090013 
1373601554601014V0020020014 
2141400544601024V0009010015 
2373700351401014V0022020016 
029290033200109  V0014000017 
0282800322001024V0013010018 
1272401332401024V0040040019 
2313100351401024V0022020020 
230300011090109  V0003000021 
2272501080800024H0003010022 
2171700717001024V0002010023 
217170063610109  V0003000024 
2141201606000024H0003010025 


B 

REF  CODE  PFX 

2040400706002024V0006010026 

B 

REF  CODE  1 

0030300716001024V0012010027 

B 

REF  CODE  2 

0020101714501024V0054020028 

F 

JOB  RELATED 

801 

010029 

F 

MIL  ONLY  DUTY 

801 

010030 

F 

MIL  ONLY  QTRS 

801 

010031 

F 

MIL  ONLY  PROF 

801 

010032 

F 

FILLER 

805 

050033 

B 

SPEC  PRE  CLIN 

306060022140111 

H0009090034 

B 

NOT  AVAILABLE 

320200009070111 

H0003030035 

BPROV2  ADDLl  (YES) 

208080006060011 

V0001010036 

B 

ADDL  PROCl 

1110701071601024V0050050037 

BPROV2  ADDL2  (YES) 

202020006060011 

V0001010038 

B 

ADDL  PROC2 

105010107 1601024V0050050039 

B 

ADMITTED 

223230019190011 

V0001010040 

BUNL  REAS  PRIM  PFX 
B  UNL  REAS  PRIM 
B  UNL  REAS  SEC  PFX 
B  UNL  REAS  SEC 

B  FOLLOW/R  OUT 

B  PROC  PROVl  (A) 

B  PROC  PROVl  (B) 

B  PROC  PROVl  (C) 

B  PROC  PROVl  (D) 

B  PROC  PiiOVl  (E) 

B  PROr  PROVl  (F) 


2121200747602024V0002010041 
1110701748301034V0050050042 
2060600747602024V0002010043 
1050101748301034V0050050044 
2383800272601024V0002010045 
347470007140111  H0008080046 
335350007080111  H0002020047 
335350010160111  H0007070048 
323230008080011  H0001010049 
323230010100011  H0001010050 
323230012150111  H0004040051 
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B  PROC  PROVl  (G) 
B  PROC  PROV2  (A) 
B  PROC  PROV2  (B) 
B  PROC  PROV2  (C) 
B  PROC  PROV2  (D) 
B  PROC  PROV2  (E) 
B  PROC  PRCV2  (F) 
B  PROC  PROV2  (G) 
B  DXl  COLl  (A) 

B  DXl  COLl  (B) 

B  DXl  COLl  (C) 

B  DXl  COLl  (D) 

B  DXl  COL2  (A) 

B  DXl  COL2  (B) 

B  DXl  COL2  (C) 

B  DXl  COL2  (D) 

B  DXl  COL2  (E) 

B  DXl  COL2  (F) 

B  DXl  COL2  (G) 

B  DXl  COL2  (H) 

B  DXl  COL3  (A) 

B  DXl  COL3  (B) 

B  DXl  COL3  (C) 

B  DXl  COL3  (D) 

B  DXl  COL3  (E) 

B  DXl  COL3  (F) 

B  DXl  COL3  (G) 

B  DXl  COL3  (H) 

B  DXl  COL4  (A) 

B  DXl  COL4  (B) 

B  DXl  COL4  (C) 

B  DXl  COL4  (D) 

B  DXl  COL4  (E) 

B  DX2  (A) 

B  DX2  (B) 

B  DX2  (C) 

B  DX2  (D) 

B  DX2  (E) 

B  DX2  (F) 

B  DX2  (G) 

B  DX2  (H) 

B  DX2  (I) 

B  DX2  (J) 

B  DX2  (K) 

B  DX2  (L) 

B  DX2  (M) 

B  DX2  (N) 

B  DX2  (O) 

B  DX2  (P) 

B  DX2  (Q) 

B  DX2  (R) 

B  DX2  (S) 

B  DX2  (T) 

B  DX2  (U) 

B  DX2  (V) 


323230017170011  H0001010052 
346460007140111  H0008080053 
334340007080111  H0002020054 
334340010160111  H0007070055 
322220008080011  H0001010056 
322220010100011  H0001010057 
322220012150111  H0004040058 
322220017170011  H0001010059 
247470031440109  V0014000060 
247470047550109  V0009000061 
247470058600109  V0003000062 
2474700637601024V0014020063 
235350029310109  V0003000064 
235350034470109  V0014000065 
235350049510109  V0003000066 
235350053570109  V0005000067 
235350059590009  V0001000068 
235350061610009  V0001000069 
235350063640109  V0002000070 
2353500667101024V0006020071 
223230029350109  V0007000072 
223230037420109  V0006000073 
223230045490109  V0005000074 
223230052550109  V0004000075 
223230058650109  V0008000076 
223230068710109  V0004000077 
223230073740109  V0002000078 
2232300767801024V0003020079 
211110029300109  V0002000080 
211110032320009  V0001000081 
211110035600109  V0026000082 
211110063660109  V0004000083 
2111100686800024V0001020084 
346460031440111  H0014140085 
346460047550111  H0009090086 
346460058600111  H0003030087 
346460063760111  H0014140088 
334340029310111  H0003030089 
334340034470111  H0014140090 
334340049510111  H0003030091 
334340053570111  H0005050092 
334340059590011  H0001010093 
334340061610011  H0001010094 
334340063640111  H0002020095 
334340066710111  H0006060096 
322220029350111  H0007070097 
322220037420111  H0006060098 
322220045490111  H0005050099 
322220052550111  H0004040100 
322220058650111  H0008080101 
322220068710111  H0004040102 
322220073740111  H0002020103 
322220076780111  H0003030104 
310100029300111  H0002020105 
310100032320011  H0001010106 
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B  DX2  (W)  310100035600111  H0026260107 
B  DX2  (X)  310100063660111  H0004040108 
//EOF0538 
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610  OPHTHAMOLOGY 


SCAN610.FIL 


H03830247NY00510PHTHAMOLOGY  * 

H010219  * 

B  LITHO  739160104040011  H0024080001 

B  UCA  PFX  2090900706202024V0005010002 

B  UCA  CODE  1  0080800716001024V0012010003 

B  UCA  CODE  2  0070601714501024V0054020004 

F  OTHER  UCA  801  010005 

B  DATE  (MO)  2434300574601014V0012020006 

B  DATE  (DY)1  1454500555201014V0004010007 

B  DATE  (DY)2  1444400554601014V0010010008 

B  PROVl  PFXl  044440033200109  V0014000009 

B  PROVl  PFX2  0434300322001014V0013010010 

B  PROVl  CODE  1423901332401014V0040040011 

B  SSN  1332501554601014V0090090012 

B  FMP  1373601554601014V0020020013 

B  VISIT  COUNT  2141400544601024V0009010014 

B  PROVl  TIME  2373700351401014V0022020015 

B  PROV2  PFXl  029290033200109  V0014000016 

B  PROV2  PFX2  0282800322001024V0013010017 

B  PROV2  CODE  1272401332401024V0040040018 

B  PROV2  TIME  23 13 100351401024V0022020019 

BREASON  FOR  #2  (1)  230300011090109  V0003000020 

BREASON  FOP  #2  (2)  2272501080800024H0003010021 

B  IF  NOT  SCHED  2171700717001024V0002010022 

BIF  NOT  CLINIC  (1)  217170063610109  V0003000023 

BIF  NOT  CLINIC  (2)  2 141201606000024H0003010024 

B  REF  CODE  PFX  2040400706002024V0006010025 

B  REF  CODE  1  0030300716001024V0012010026 

B  REF  CODE  2  0020101714501024V0054020027 

B  JOB  RELATED  217170032320011  V0001010028 
B  MIL  ONLY  DUTY  2202000241410024V0002010029 

B  MIL  ONLY  QTRS  2191900222001024V0003010030 

B  MIL  ONLY  PROF  2191900181501024V0004010031 

F  FILLER  805  050032 

B  SPEC  PRE  CLIN  306060022140111  H0009090033 

B  NOT  AVAILABLE  320200009070111  H0003030034 

BPROV2  ADDLl  (YES)  208080006060011  V0001010035 
B  ADDL  PROCl  1110701071601024V0050050036 

BPROV2  ADDL2  (YES)  202020006060011  V0001010037 
B  ADDL  PROC2  1050101071601024V0050050038 

B  ADMITTED  223230023230011  V0001010039 

BUNL  REAS  PRIM  PFX  2 12 1 200747602024V0002010040 
B  UNL  REAS  PRIM  1110701748301034V0050050041 

B  UNL  REAS  SEC  PFX  2060600747602024V0002010042 
B  UNL  REAS  SEC  1050101748301034V0050050043 

B  FOLLOW/R  OUT  2383800282701024V0002010044 

B  PROC  PROVl  (A)  347470008080011  H0001010045 

B  PROC  PROVl  (B)  347470011120111  H0002020046 

B  PROC  PROVl  (C)  347470015240111  H0010100047 

B  PROC  PROVl  (D)  335350008100111  H0003030048 

B  PROC  PROVl  (E)  335350013240111  H0012120049 

B  PROC  PROVl  (F)  323230007180111  H0012120050  . 

B  PROC  PROVl  (G)  323230020200011  H0001010051 
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PROC  PROV2  (A)  346460008080011  H0001010052 

PROC  PR0V2  (B)  346460011120111  H0002020053 

PROC  PR0V2  (C)  346460015240111  H0010100054 

PROC  PROV2  (D)  334340008100111  H0003030055 

PROC  PROV2  (E)  334340013240111  H0012120056 

PROC  PROV2  (F)  322220007180111  H0012120057 

PROC  PROV2  (G)  322220020200011  H0001010058 

DXl  COLl  (A)  247470033430109  V0011000059 

DXl  COLl  (B)  2474700466401024V0019020060 

DXl  COL2  (A)  235350030430109  V0014000061 

DXl  COL2  (B)  235350046510109  V0006000062 

DXl  COL2  (C)  2353500546101024V0008020063 

DXl  COL3  (A)  223230030450109  V0016000064 

DXl  COL3  (B)  223230048570109  V0010000065 

DXl  COL3  (C)  2232300596401024V0006020066 

DXl  COL4  (A)  211110030310109  V0002000067 

DXl  COL4  (B)  211110034360109  V0003000068 

DXl  COL4  (C)  211110039490109  V0011000069 

DXl  COL4  (D)  2111100515201024V0002020070 

DX2  (A)  346460033430111  H0011110071 

DX2  (B)  346460046640111  H0019190072 

DX2  (C)  334340030430111  H0014140073 

DX2  (D)  334340046510111  H0006060074 

DX2  (E)  334340054610111  H0008080075 

DX2  (F)  322220030450111  H0016160076 

DX2  (G)  322220048570111  H0010100077 

DX2  (H)  322220059640111  H0006060078 

DX2  (I)  310100030310111  H0002020079 

DX2  (J)  310100034360111  H0003030080 

DX2  (K)  310100039490111  H0011110081 

//EOF0533 
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620  OPTOMETRY 


SCAN620.FIL 


H03830247NY00510PTOMETRY  * 
H010246  * 
B  LITHO  739160104040011  H0024080001 
B  UCA  PFX  2090900706202024V0005010002 
B  UCA  CODE  0080601714501024V0081030003 
B  OTHER  UCA  2171205818100024H0002010004 
B  DATE  (MO)  2434300574601014V0012020005 
B  DATE  (DY)  1454401554601014V0020020006 
B  PROVl  PFXl  044440033200109  V0014000007 
B  PROVl  PFX2  0434300322001014V0013010008 
B  PROVl  CODE  1423901332401014V0040040009 
B  SSN  1332501554601014V0090090010 
B  FMP  1373601554601014V0020020011 
B  VISIT  COUNT  2141400544601024V0009010012 
B  PROVl  TIME  2373700351401014V0022020013 
B  PROV2  PFXl  029290033200109  V0014000014 
B  PROV2  PFX2  0282800322001024V0013010015 
B  PROV2  CODE  1272401332401024V0040040016 
B  PROV2  TIME  2313100351401024V0022020017 
BREASON  FOR  #2  (1)  230300011090109  V0003000018 
BREASON  FOR  #2  (2)  2272501080800024H0003010019 
B  IF  NOT  SCHED  2171700717001024V0002010020 
BIF  NOT  CLINIC  (1)  217170063610109  V0003000021 
BIF  NOT  CLINIC  (2)  2141201606000024H0003010022 
B  REF  CODE  PFX  2040400706002024V0006010023 
B  REF  CODE  0030101714501024V0081030024 
B  JOB  RELATED  217170032320011  V0001010025 
B  MIL  ONLY  DUTY  2202000241410024V0002010026 
B  MIL  ONLY  QTRS  2 191900222001024V0003010027 
B  MIL  ONLY  PROF  2191900181501024V0004010028 
F  FILLER  805  050029 
B  SPEC  PRE  CLIN  306060022140111  H0009090030 
B  NOT  AVAILABLE  320200009070111  H0003030031 
BPROV2  ADDLl  (YES)  208080006060011  V0001010032 
B  ADDL  PROCl  1110701071601024V0050050033 
BPROV2  ADDL2  (YES)  202020006060011  V0001010034 
B  ADDL  PROC2  1050101071601024V0050050035 
F  ADMITTED  801  010036 
BUNL  REAS  PRIM  PFX  2121200747602024V0002010037 
B  UNL  REAS  PRIM  1110701748301034V0050050038 
B  UNL  REAS  SEC  PFX  2060600747602024V0002010039 
B  UNL  REAS  SEC  1050101748301034V0050050040 
B  FOLLOW/R  OUT  2383800403901024V0002010041 


B 

PROC 

PROVl 

(A) 

347470008110111 

H0004040042 

B 

PROC 

PROVl 

(B) 

347470014180111 

H0005050043 

B 

PROC 

PROVl 

(C) 

347470021240111 

H0004040044 

B 

PROC 

PROVl 

(D) 

347470027280111 

H0002020045 

B 

PROC 

PROVl 

(E) 

347470031330111 

H0003030046 

B 

PROC 

PROVl 

(F) 

335350008100111 

H0003030047 

B 

PROC 

PROVl 

(G) 

335350013310111 

H0019190048 

B 

PROC 

PROVl 

(H) 

323230008150111 

H0008080049 

B 

PROC 

PROVl 

(I) 

323230018200111 

H0003030050 

B 

PROC 

PROV2 

(A) 

346460008110111 

H0004040051 
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PROC  PROV2  (B)  346460014180111  H0005050052 

PROC  PROV2  (C)  346460021240111  H0004040053 

PROC  PROV2  (D)  346460027280111  H0002020054 

PROC  PROV2  (E)  346460031330111  H0003030055 

PROC  PROV2  (F)  334340008100111  H0003030056 

PROC  PROV2  (G)  334340013310111  H0019190057 

PROC  PROV2  (H)  322220008150111  H0008080058 

PROC  PROV2  (I)  322220018200111  H0003030059 

OTHER  CODES  (A)  323230023290111  H0007070060 

OTHER  CODES  (B)  311110018230111  H0006060061 

OTHER  CODES  (C)  311110026330111  H0008080062 

DXl  COLl  (A)  247470044530109  V0010000063 

DXl  COLl  (B)  247470056640109  V0009000064 

DXl  COLl  (C)  247470067760109  V0010000065 

DXl  COLl  (D)  2474700798301024V0005020066 

DXl  COL2  (A)  235350042470109  V0006000067 

DXl  COL2  (B)  235350051580109  V0008000068 

DXl  COL2  (C)  2353500617601024V0016020069 

DXl  COL3  (A)  223230042450109  V0004000070 

DXl  COL3  (B)  223230047560109  V0010000071 

DXl  COL3  (C)  223230059630109  V0005000072 

DXl  COL3  (D)  223230066710109  V0006000073 

DXl  COL3  (E)  2232300737300024V0001020074 

DXl  COL4  (A)  211110042430109  V0002000075 

DXl  COL4  (B)  211110045450009  V0001000076 

DXl  COL4  (C)  211110048480009  V0001000077 

DXl  COL4  (D)  211110050550109  V0006000078 

DXl  COL4  (E)  211110057570009  V0001000079 

DXl  COL4  (F)  211110059610109  V0003000080 

DXl  COL4  (G)  2111100646501024V0002010081 

DX2  (A)  346460044530111  H0010100082 

DX2  (B)  346460056640111  H0009090083 

DX2  (C)  346460067760111  H0010100084 

DX2  (D)  346460079830111  H0005050085 

DX2  (E)  334340042470111  H0006060086 

DX2  (F)  334340051580111  H0008080087 

DX2  (G)  334340061760111  H0016160088 

DX2  (H)  322220042450111  H0004040089 

DX2  (I)  322220047560111  H0010100090 

DX2  (J)  322220059630111  H0005050091 

DX2  (K)  322220066710111  H0006060092 

DX2  (L)  322220073730011  H0001010093 

DX2  (M)  310100042430111  H0002020094 

DX2  (N)  310100045450011  H0001010095 

DX2  (O)  310100048480011  H0001010096 

DX2  (P)  310100050550111  H0006060097 

DX2  (Q)  310100057570011  H0001010098 

DX2  (R)  310100059610111  H0003030099 

//EOF0344 
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630  ORTHO  APPLIANCE/ CAST 


SCAN630.FIL 


H02830247NY005 lORTHO  APPLIANCE/CAST 
H0342 


B 

LITHO 

B 

UCA  PFX 

B 

UCA  CODE  1 

B 

UCA  CODE  2 

B 

OTHER  UCA 

B 

DATE  (MO) 

B 

DATE  (DY)1 

B 

DATE  (DY)2 

B 

PROVl  PFXl 

B 

PROVl  PFX 2 

B 

PROVl  CODE 

B 

SSN 

B 

FMP 

B 

VISIT  COUNT 

B 

PROVl  TIME 

B 

PROV2  PFXl 

B 

PROV2  PFX2 

B 

PROV2  CODE 

B 

rROV2  TIME 

BREASON  FOR  #2  (1) 
BREASON  FOR  #2  (2) 
B  IF  NOT  SCHED 
BIF  NOT  CLINIC  (1) 
BIF  NOT  CLINIC  (2) 


* 
* 

739160104040011  H0024080001 
2090900706202024V0005010002 
0080800716001024V0012010003 
0070601714501024V0054020004 
2171700818100024V0001010005 
2434300574601014V0012020006 
1454500555201014V0004010007 
1444400554601014V0010010008 
044440033200109  V0014000009 
0434300322001014V0013010010 
1423901332401014V0040040011 
13 32 501554 601014V0090090012 
1373601554601014V002 0020013 
2 14 1400544 601024V0009010014 
2 373700351401014 V0022020015 
029290033200109  V0014000016 
0282800322001024V0013010017 
1272401332401024V0040040018 
2313100351401024V0022020019 
230300011090109  V0003000020 
2272501080800024H0003010021 
2171700717001024V0002010022 
217170063610109  V0003000023 
2141201606000024H0003010024 
2040400706002024V0006010025 
0030300716001024V0012010026 
0020101714501024V0054020027 
801  010028 
801  010029 
801  010030 
801  010031 
805  050032 
306060022140111  H0009090033 
320200009070111  H0003030034 
208080006060011  V0001010035 
11 1070107 1601024V0050050036 
202020006060011  V0001010037 
1 05010107160102 4 V0050050038 
801  010039 
2121200747602024V0002010040 
1110701748301034V0050050041 


B  REF  CODE  PFX 
B  REF  CODE  1 

B  REF  CODE  2 

F  JOB  RELATED 
F  MIL  ONLY  DUTY 

F  MIL  ONLY  QTRS 

F  MIL  ONLY  PROF 

F  FILLER 

B  SPEC  PRE  CLIN 

B  NOT  AVAILABLE 
BPROV2  ADDLl  (YES) 

B  ADDL  PROCl 
BPROV2  ADDL2  (YES) 

B  ADDL  PROC2 
F  ADMITTED 

BUNL  REAS  PRIM  PFX 

B  UNL  REAS  PRIM 
B  UNL  REAS  SEC  PFX  2060600747602024V0002010042 


B  UNL  REAS  SEC 
F  FOLLOW/R  OUT 


1050101748301034V0050050043 
801  010044 


B 

PROC 

PROVl 

(A) 

34747C009210111 

H0013130045 

B 

PROC 

PROVl 

(B) 

347470024270111 

H0004040046 

B 

PROC 

PROVl 

(C) 

347470030340111 

H0005050047 

B 

PROC 

PROVl 

(D) 

347470037440111 

H0008080048 

B 

PROC 

PROVl 

(E) 

347470047510111 

H0005050049 

B 

PROC 

PROVl 

(F) 

347470053550111 

H0003030050 

B 

PROC 

PROVl 

(G) 

335350008100111 

H0003030051 
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B  PROC  PROV2  (A)  346460009210111  H0013130052 
B  PROC  PROV2  (B)  346460024270111  H0004040053 
B  PROC  PROV2  (C)  346460030340111  H0005050054 
B  PROC  PROV2  (D)  346460037440111  H0008080055 
B  PROC  PROV2  (E)  346460047510111  H0005050056 
B  PROC  PROV2  (F)  346460053550111  H0003030057 
B  PROC  PROV2  (G)  334340008100111  H0003030058 
B  OTHER  CODES  (A)  335350017210111  H0005050059 
B  OTHER  CODES  (B)  335350026410111  H0016160060 
B  OTHER  CODES  (C)  335350043560111  H0014140061 
B  OTHER  CODES  (D)  335350059620111  H0004040062 
B  OTHER  CODES  (E)  323230026340111  H0009090063 
B  OTHER  CODES  (F)  323230037550111  H0019190064 
B  OTHER  CODES  (G)  323230058620111  H0005050065 
B  OTHER  CODES  (H)  311110026350111  H0010100066 
B  OTHER  CODES  (I)  311110038490111  H0012120067 
B  OTHER  CODES  (J)  311110052640111  H0013130068 
B  DXl  COLl  (A)  247470070710109  V0002000069 
B  DXl  COLl  (B)  2474700738201024V0010020070 
B  DXl  C0L2  2353500708001024V0011020071 
B  DX2  (A)  346460070710111  H0002020072 
B  DX2  (B)  346460073820111  H0010100073 
B  DX2  (C)  334340070800111  H0011110074 
//EOF0553 
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640  ORTHOPEDICS 


SCAN640.FIL 


H03830247NY00510RTHOPEDICS  * 
H010227  * 
B  LITHO  739160104040011  H0024080001 
B  UCA  PFX  2090900706202024V0005010002 
B  UCA  CODE  1  0080800716001024V0012010003 
B  UCA  CODE  2  0070601714501024V0054020004 
B  OTHER  UCA  1  217170081810009  V0001000005 
B  OTHER  UCA  2  2121200818100024V0001010006 
B  DATE  (MO)  2434300574601014V0012020007 
B  DATE  (DY)1  1454500555201014V0004010008 
B  DATE  (DY)2  1444400554601014V0010010009 
B  PROVl  PFXl  044440033200109  V0014000010 
B  PROVl  PFX2  0434300322001014V0013010011 
B  PROVl  CODE  1423901332401014V0040040012 
B  SSN  1332501554601014V0090090013 
B  FMP  1373601554601014V0020020014 
B  VISIT  COUNT  2141400544601024V0009010015 
B  PROVl  TIME  2373700351401014V0022020016 
B  PROV2  PFXl  029290033200109  V0014000017 
B  PROV2  PFX2  0282800322001024V0013010018 
B  PROV2  CODE  1272401332401024V0040040019 
B  PROV2  TIME  2313100351401024V0022020020 
BREASON  FOR  #2  (1)  230300011090109  V0003000021 
BREASON  FOR  #2  (2)  2272501080800024H0003010022 
B  IF  NOT  SCHED  2171700717001024V0002010023 
BIF  NOT  CLINIC  (1)  217170063610109  V0003000024 
BIF  NOT  CLINIC  (2)  2141201606000024H0003010025 
B  REF  CODE  PFX  2040400706002024V0006010026 
B  REF  CODE  1  0030300716001024V0012010027 
B  REF  CODE  2  0020101714501024V0054020028 
B  JOB  RELATED  217170032320011  V0001010029 
B  MIL  ONLY  DUTY  2202000241410024V0002010030 
B  MIL  ONLY  QTRS  2191900222001024V0003010031 
B  MIL  ONLY  PROF  2191900181501024V0004010032 
F  FILLER  805  050033 
B  SPEC  PRE  CLIN  306060022140111  H0009090034 
B  NOT  AVAILABLE  320200009070111  H0003030035 
BPROV2  ADDLl  (YES)  208080006060011  V0001010036 
B  ADDL  PROCl  1110701071601024V0050050037 
BPROV2  ADDL2  (YES)  202020006060011  V0001010038 
B  ADDL  PROC2  1050101071601024V0050050039 
B  ADMITTED  223230021210011  V0001010040 
BUNL  REAS  PRIM  PFX  2121200747602024V0002010041 
B  UNL  REAS  PRIM  1110701748301034V0050050042 
B  UNL  REAS  SEC  PFX  2060600747602024V0002010043 
B  UNL  REAS  SEC  1050101748301034V0050050044 
B  FOLLOW/R  OUT  2383800272601024V0002010045 
B  PROC  PROVl  (A)  347470008120111  H0005050046 
B  PROC  PROVl  (B)  335350008130111  H0006060047 
B  PROC  PROVl  (C)  335350016180111  H0003030048 
B  PROC  PROVl  (D)  323230008170111  H0010100049 
B  PROC  PROVl  (E)  323230019190011  H0001010050 
B  PROC  PROVl  (A)  346460008120111  H0005050051 
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B 

PROC 

PROVl 

(B) 

334340008130111 

H0006060052 

B 

PROC 

PROVl 

(C) 

334340016180111 

H0003030053 

B 

PROC 

PROVl 

(D) 

322220008170111 

H0010100054 

B 

PROC 

PROVl 

(E) 

322220019190011 

H0001010055 

B 

DXl 

COLl 

(A) 

247470031490109 

V0019000056 

B 

DXl 

COLl 

(B) 

247470052540109 

V0003000057 

B 

DXl 

COLl 

(C) 

2474700566801024V0013020058 

B 

DXl 

COL2 

(A) 

235350029440109 

V0016000059 

B 

DXl 

COL2 

(B) 

235350047490109 

V0003000060 

B 

DXl 

COL2 

(C) 

235350051560109 

V0006000061 

B 

DXl 

COL2 

(D) 

2353500597601024V0018020062 

B 

DXl 

COL3 

(A) 

223230029380109 

V0010000063 

B 

DXl 

COL3 

(B) 

223230040410109 

V0002000064 

B 

DXl 

COL3 

(C) 

223230044490109 

V0006000065 

B 

DXl 

COL3 

(D) 

2232300516501024V0015020066 

B 

DXl 

COL4 

(A) 

211110029450109 

V0017000067 

B 

DXl 

COL4 

(B) 

211110047510109 

V0005000068 

B 

DXl 

COL4 

(C) 

2111100535300024V0001020069 

B 

DX2 

(A) 

346460031490111 

H0019190070 

B 

DX2 

(B) 

346460052540111 

H0003030071 

B 

DX2 

(C) 

346460056680111 

H0013130072 

B 

DX2 

(D) 

334340029440111 

H0016160073 

B 

DX2 

(E) 

334340047490111 

H0003030074 

B 

DX2 

(F) 

334340051560111 

H0006060075 

B 

DX2 

(G) 

334340059760111 

H0018180076 

B 

DX2 

(H) 

322220029380111 

H0010100077 

B 

DX2 

(I) 

322220040410111 

H0002020078 

B 

DX2 

(J) 

322220044490111 

H0006060079 

B 

DX2 

(K) 

322220051650111 

H0015150080 

B 

DX2 

(L) 

310100029450111 

H0017170081 

B 

DX2 

(M) 

310100047510111 

H0005050082 

//EOF0530 
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650  OCCUPATIONAL  THERAPY 


SCAN650.FIL 


H03830247NY00510CCUPATIONAL  THERAPY 
H010220 


* 
* 

739160104040011  H0024090001 
801  010002 

801  010003 

802  020004 

801  010005 

2434300574601014V0012020006 
1454500555201014V0004010007 
1444400554601014V0010010008 
044440033200109  V0014000009 
0434300322001014V0013010010 
1423901332401014V0040040011 
1332501554601014V0090090012 
1373601554601014V0020020013 
2141400544601024V0009010014 
2373700351401014V0022020015 
029290033200109  V0014000016 
0282800322001024V0013010017 
1272401332401024V0040040018 
2313100351401024V0022020019 
230300011090109  V0003000020 
227250108080009  H0003000021 


B  LITHO 

F  UCA  PFX 

F  UCA  CODE  1 

F  UCA  CODE  2 

F  OTHER  UCA 

B  DATE  (MO) 

B  DATE  (DY)1 

B  DATE  (DY)2 

B  PROVl  PFXl 

B  PROVl  PFX2 

B  PROVl  CODE 

B  SSN 

B  FMP 

B  VISIT  COUNT 

B  PROVl  TIME 

B  PROV2  PFXl 

B  PROV2  PFX2 

B  PROV2  CODE 

B  PROV2  TIME 

BREASON  FOR  #2  (1) 

BREASON  FOR  #2  (2) 

BREASON  FOR  #2  (CO) 2303000121200024V0001010022 


B  IF  NOT  SCHED 
BIF  NOT  CLINIC  (1) 
BIF  NOT  CLINIC  (2) 
B  REF  CODE  PFX 
B  REF  CODE  1 

B  REF  CODE  2 

B  JOB  RELATED 
B  MIL  ONLY  DUTY 

B  MIL  ONLY  QTRS 

B  MIL  ONLY  PROF 

B  REF  CODE  SING 

F  FILLER 

B  SPEC  PRE  CLIN 

B  NOT  AVAILABLE 

BPROV2  ADDLl  (YES) 
B  ADDL  PROCl 

BPROV2  ADDL2  (YES) 
B  ADDL  PROC2 

F  ADMITTED 


2171700717001024V0002010023 
217170063610109  V0003000024 
2141201606000024H0003010025 
2040400706002024V0006010026 
0030300716001024V0012010027 
0020101714501024V0054020028 
217170032320011  V0001010029 
2202000241410024V0002010030 
2191900222001024V0003010031 
2191900181501024V0004010032 
2090900704501024V0026020033 
803  030034 

306060022140111  H0009090035 
320200009070111  H0003030036 
208080006060011  V0001010037 
1110701071601024V0050050038 
202020006060011  V0001010039 
1050101071601024V0050050040 
801  010041 

BUNL  REAS  PRIM  PFX  2121200747602024V0002010042 


B 


UNL  REAS  PRIM  1110701748301034V0050050043 


B  UNL  REAS  SEC  PFX  2060600747602024V0002010044 


B  UNL  REAS  SEC 
B  FOLLOW/ R  OUT 
B  PROC  PROVl  (A) 
B  PROC  PROVl  (B) 
B  PROC  PROVl  (C) 
B  PROC  PROVl  (D) 
B  PROC  PROVl  (E) 


1050101748301034V0050050045 
2383800494801024V0002010046 
347470008090111  H0002020047 
347470011150111  H0005050048 
347470017260111  H0010100049 
347470028330111  H0006060050 
347470035420111  H0008080051 


-56- 


B  PROC  PROVl  (F)  335350008170111  H0010100052 
B  PROC  PROVl  (G)  335350019250111  H0007070053 
B  PROC  PROVl  (H)  335350027320111  H0006060054 
B  PROC  PROVl  (I)  335350036420111  H0007070055 
B  PROC  PROVl  (J)  323230008110111  H0004040056 
B  PROC  PROVl  (K)  323230013140111  H0002020057 
B  PROC  PROVl  (L)  323230016270111  H0012120058 
B  PROC  PROVl  (M)  323230029370111  H0009090059 
B  PROC  PROVl  (N)  323230039460111  H0008080060 
B  PROC  PROVl  (O)  311110019230111  H0005050061 
B  PROC  PROVl  (P)  311110025330111  H0009090062 
B  PROC  PROVl  (Q)  311110036450111  H0010100063 
B  PROC  PROV2  (A)  346460008090111  H0002020064 
B  PROC  PROV2  (B)  346460011150111  H0005050065 
B  PROC  PROV2  (C)  346460017260111  H0010100066 
B  PROC  PROV2  (D)  346460028330111  H0006060067 
B  PROC  PROV2  (E)  346460035420111  H0008080068 
B  PROC  PROV2  (F)  334340008170111  H0010100069 
B  PROC  PROV2  (G)  334340019250111  H0007070070 
B  PROC  PROV2  (H)  334340027320111  H0006060071 
B  PROC  PROV2  (I)  334340036420111  H0007070072 
B  PROC  PROV2  (J)  322220008110111  H0004040073 
B  PROC  PROV2  (K)  322220013140111  H0002020074 
B  PROC  PROV2  (L)  322220016270111  H0012120075 
B  PROC  PROV2  (M)  322220029370111  H0009090076 
B  PROC  PROV2  (N)  322220039460111  H0008080077 
B  PROC  PROV2  (O)  310100019230111  H0005050078 
B  PROC  PROV2  (P)  310100025330111  H0009090079 
B  PROC  PROV2  (Q)  310100036450111  H0010100080 
B  DXl  COLl  (A)  247470053690109  V0017000081 
B  DXl  COLl  (B)  247470072760109  V0005000082 
B  DXl  COLl  (C)  2474700788301024V0006020083 
B  DXl  COL2  (A)  235350050540109  V0005000084 
B  DXl  COL2  (B)  2353500578201024V0026020085 
B  DXl  COL3  (A)  223230051720109  V0022000086 
B  DXl  COL3  (B)  223230074780109  V0005000087 
B  DXl  COL3  (C)  2232300808301024V0004020088 
B  DXl  COL4  (A)  211110050510109  V0002000089 
B  DXl  COL4  (B)  211110053570109  V0005000090 
B  DXl  COL4  (C)  211110060650109  V0006000091 
B  DXl  COL4  (D)  2111100676801024V0002020092 
B  DX2  (A)  346460053690111  H0017170093 
B  DX2  (B)  346460072760111  H0005050094 
B  DX2  (C)  346460078830111  H0006060095 
B  DX2  (D)  334340050540111  H0005050096 
B  DX2  (E)  334340057820111  H0026260097 
B  DX2  (F)  322220051720111  H0022220098 
B  DX2  (G)  322220074780111  H0005050099 
B  DX2  (H)  322220080830111  H0004040100 
B  DX2  (I)  310100050510111  H0002020101 
B  DX2  (J)  310100053570111  H0005050102 
B  DX2  (K)  310100060650111  H0006060103 
//EOF0683  * 
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660  PAIN/PHYSICAL  MEDICINE  SCAN660.FIL 

H03830247NY0051PAIN/PHYSICAL  MEDICINE  * 
H010232  * 
B  LITHO  739160104040011  H0024080001 
B  UCA  PFX  2090900706202024V0005010002 
B  UCA  CODE  1  0080800716001024V0012010003 
B  UCA  CODE  2  0070601714501024V0054020004 
B  OTHER  UCA  2171700818100024V0001010005 
B  DATE  (MO)  2434300574601014V0012020006 
B  DATE  (DY)1  1454500555201014V0004010007 
B  DATE  (DY)2  1444400554601014V0010010008 
B  PROVl  PFXl  044440033200109  V0014000009 
B  PROVl  PFX2  0434300322001014V0013010010 
B  PROVl  CODE  1423901332401014V0040040011 
B  SSN  1332501554601014V0090090012 
B  FMP  1373601554601014V0020020013 
B  VISIT  COUNT  2141400544601024V0009010014 
B  PROVl  TIME  2373700351401014V0022020015 
B  PROV2  PFXl  029290033200109  V0014000016 
B  PROV2  PFX2  0282800322001024V0013010017 
B  PROV2  CODE  1272401332401024V0040040018 
B  PROV2  TIME  2313100351401024V0022020019 
BREASON  FOR  #2  (1)  230300011090109  V0003000020 
BREASON  FOR  #2  (2)  2272501080800024H0003010021 
B  IF  NOT  SCHED  2171700717001024V0002010022 
BIF  NOT  CLINIC  (1)  217170063610109  V0003000023 
BIF  NOT  CLINIC  (2)  2141201606000024H0003010024 
B  REF  CODE  PFX  2040400706002024V0006010025 
B  REF  CODE  1  0030300716001024V0012010026 
B  REF  CODE  2  0020101714501024V0054020027 
B  JOB  RELATED  217170032320011  V0001010028 
B  MIL  ONLY  DUTY  2202000241410024V0002010029 
B  MIL  ONLY  QTRS  2191900222001024V0003010030 
B  MIL  ONLY  PROF  2191900181501024V0004010031 
F  FILLER  805  050032 
B  SPEC  PRE  CLIN  306060022140111  H0009090033 
B  NOT  AVAILABLE  320200009070111  H0003030034 
BPROV2  ADDLl  (YES)  208080006060011  V0001010035 
B  ADDL  PROCl  1110701071601024V0050050036 
BPROV2  ADDL2  (YES)  202020006060011  V0001010037 
B  ADDL  PROC2  1050101071601024V0050050038 
B  ADMITTED  235350024240011  V0001010039 
BUNL  REAS  PRIM  PFX  2121200747602024V0002010040 
B  UNL  REAS  PRIM  1110701748301034V0050050041 
B  UNL  REAS  SEC  PFX  2060600747602024V0002010042 
B  UNL  REAS  SEC  1050101748301034V0050050043 
B  FOLLOW/R  OUT  2383800343301024V0002010044 
B  PROC  PROVl  (A)  347470010140111  H0005050045 
B  PROC  PROVl  (B)  347470016170111  H0002020046 
B  PROC  PROVl  (C)  347470019210111  H0003030047 
B  PROC  PROVl  (D)  335350011140111  H0004040048 
B  PROC  PROVl  (E)  335350016200111  H0005050049 
B  PROC  PROVl  (F)  335350022220011  H0001010050 
B  PROC  PROVl  (G)  323230009210111  H0013130051 
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B  PROC  PROVl  (H)  323230023300111  H0008080052 
B  PROC  PROVl  (I)  311110020220111  H0003030053 
B  PROC  PROVl  (J)  311110024280111  H0005050054 
B  PROC  PROVl  (K)  311110030300011  H0001010055 
B  PROC  PROV2  (A)  346460010140111  H0005050056 
B  PROC  PROV2  (B)  346460016170111  H0002020057 
B  PROC  PROV2  (C)  346460019210111  H0003030058 
B  PROC  PROV2  (D)  334340011140111  H0004040059 
B  PROC  PROV2  (E)  334340016200111  H0005050060 
B  PROC  PROV2  (F)  334340022220011  H0001010061 
B  PROC  PROV2  (G)  322220009210111  H0013130062 
B  PROC  PROV2  (H)  322220023300111  H0008080063 
B  PROC  PROV2  (I)  310100020220111  H0003030064 
B  PROC  PROV2  (J)  310100024280111  H0005050065 
B  PROC  PROV2  (K)  310100030300011  H0001010066 
B  DXl  COLl  (A)  247470038420109  V0005000067 
B  DXl  COLl  (B)  247470044480109  V0005000068 
B  DXl  COLl  (C)  247470050510109  V0002000069 
B  DXl  COLl  (D)  247470053550109  V0003000070 
B  DXl  COLl  (E)  247470057600109  V0004000071 
B  DXl  COLl  (F)  2474700638101024V0019020072 
B  DXl  COL2  (A)  235350038670109  V0030000073 
B  DXl  COL2  (B)  235350070810109  V0012000074 
B  DXl  COL2  (C)  2353500838300024V0001020075 
B  DXl  COL3  (A)  223230036390109  V0004000076 
B  DXl  COL3  (B)  223230041560109  V0016000077 
B  DXl  COL3  (C)  2232300585800024V0001020078 
B  DX2  (A)  346460038420111  H0005050079 
B  DX2  (B)  346460044480111  H0005050080 
B  DX2  (C)  346460050510111  H0002020081 
B  DX2  (D)  346460053550111  H0003030082 
B  DX2  (E)  346460057600111  H0004040083 
B  DX2  (F)  346460063810111  H0019190084 
B  DX2  (G)  334340038670111  H0030300085 
B  DX2  (H)  334340070810111  H0012120086 
B  DX2  (I)  334340083830011  H0001C10087 
B  DX2  (J)  322220036390111  H0004040088 
B  DX2  (K)  322220041560111  H0016160089 
//E0F0544 
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670  PEDIATRICS 


SCAN670.FIL 


H02830247NY0051PEDIATRIC 

H0345 


B  LITHO 

B  UCA  PFX 

B  UCA  CODE  1 

B  UCA  CODE  2 

B  OTHER  UCA  1 

B  OTHER  UCA  2 

B  DATE  (MO) 

B  DATE  (DY)1 

B  DATE  (DY)2 

B  PROVl  PFXl 

B  PROVl  PFX2 

B  PROVl  CODE 

B  SSN 

B  FMP 

B  VISIT  COUNT 

B  PROVl  TIME 

B  PROV2  PFXl 

B  PROV2  PFX 2 

B  PROV2  CODE 

B  PROV2  TIME 

BREASON  FOR  #2  (1) 
BREASON  FOR  #2  (2) 
B  IF  NOT  SCHED 
BIF  NOT  CLINIC  (1) 
BIF  NOT  CLINIC  (2) 


* 
* 

739160104040011  H0024080001 
2090900706202024V0005010002 
0080800716001024V0012010003 
0070601714501024V0054020004 
217170081790109  V0003000005 
2121200817901024V0003010006 
2434300574601014V0012020007 
1454500555201014V0004010008 
1444400554601014V0010010009 
044440033200109  V0014000010 
0434300322001014V0013010011 
1423901332401014V0040040012 
13 32501554 601014V0090090013 
1373601554601014V0020020014 
2141400544601024V0009010015 
2373700351401014V0022020016 
029290033200109  V0014000017 
0282800322001024V0013010018 
1272401332401024V0040040019 
2313100351401024V0022020020 
230300011090109  V0003000021 
2272501080800024H0003010022 
2171700717001024V0002010023 
217170063610109  V0003000024 
2141201606000024H0003010025 
2040400706002024V0006010026 
0030300716001024V0012010027 
00201017 14501024V0054020028 
801  010029 
801  010030 
801  010031 
801  010032 
805  050033 
306060022140111  H0009090034 
320200009070111  H0003030035 
208080006060011  V0001010036 
1110701071601024V0050050037 
202020006060011  V0001010038 
1050101071601024V0050050039 


B  REF  CODE  PFX 
B  REF  CODE  1 

B  REF  CODE  2 

F  JOB  RELATED 
F  MIL  ONLY  DUTY 

F  MIL  ONLY  QTRS 

F  MIL  ONLY  PROF 

F  FILLER 

B  SPEC  PRE  CLIN 

B  NOT  AVAILABLE 
BPROV2  ADDLl  (YES) 

B  ADDL  PROCl 

BPROV2  ADDL2  (YES) 

B  ADDL  PROC2 

B  ADMITTED  223230024240011  V0001010040 

BUNL  REAS  PRIM  PFX  212I200747602024V0002010041 
B  UNL  REAS  PRIM  1110701748301034V0050050042 
B  UNL  REAS  SEC  PFX  2060600747602024V0002010043 


B  UNL  REAS  SEC 
B  FOLLOW/R  OUT 
B  PROC  PROVl  (A) 
B  PROC  PROVl  (B) 
B  PROC  PROVl  (C) 
B  PROC  PROVl  (D) 
B  PROC  PROVl  (E) 
B  PROC  PROV2  (A) 


1050101748301034V0050050044 
2383800292801024V0002010045 
347470008140111  H0007070046 
347470017170011  H0001010047 
347470020250111  H0006060048 
335350008200111  H0013130049 
323230008200111  H0013130050 
346460008140111  H0007070051 
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B  PROC  PROV2  (B)  346460017170011  H0001010052 
B  PROC  PROV2  (C)  346460020250111  H0006060053 
B  PROC  PROV2  (D)  334340008200111  H0013130054 
B  PROC  PROV2  (E)  322220008200111  H0013130055 
B  DXl  COLl  (A)  2474700335701024V0025020056 
B  DXl  COL2  (A)  235350031510109  V0021000057 
B  DXl  COL2  (B)  235350054580109  V0005000058 
B  DXl  COL2  (C)  235350061640109  V0004000059 
B  DXl  COL2  (D)  2353500678101024V0015020060 
B  DXl  COL3  (A)  223230031320109  V0002000061 
B  DXl  COL3  (B)  223230035430109  V0009000062 
B  DXl  COL3  (C)  223230046540109  V0009000063 
B  DXl  COL3  (D)  223230057650109  V0009000064 
B  DXl  COL3  (E)  223230068690109  V0002000065 
BDXl  COL3  (F)  223230071710009  V0001000066 
BDXl  COL3  (G)  223230073730009  V0001000067 
BDXl  COL3  (H)  223230075750009  V0001000068 
BDXl  COL3  (I)  2232300777901024V0003010069 
BDXl  COL4  (A)  211110031340109  V0004000070 
BDXl  COL4  (B)  211110038410109  V0004000071 
BDXl  COL4  (C)  211110044450109  V0002000072 
BDXl  COL4  (D)  211110047510109  V0005000073 
BDXl  COL4  (E)  211110053540109  V0002000074 
BDXl  COL4  (F)  211110057580109  V0002000075 
BDXl  COL4  (G)  211110061640109  V0004000076 
BDXl  COL4  (H)  2111100666701024V0002020077 
B  DX2  (A)  346460033570111  H0025250078 
B  DX2  (B)  334340031510111  H0021210079 
B  DX2  (C)  334340054580111  H0005050080 
B  0X2  (D)  334340061640111  H0004040081 
B  DX2  (E)  334340067810111  H0015150082 
B  DX2  (F)  322220031320111  H0002020083 
B  DX2  (G)  322220035430111  H0009090084 
B  DX2  (H)  322220046540111  H0009090085 
B  DX2  (I)  322220057650111  H0009090086 
B  DX2  (J)  322220068690111  H0002020087 
B  DX2  (K)  322220071710011  H0001010088 
B  DX2  (L)  322220073730011  H0001010089 
B  DX2  (M)  322220075750011  H0001010090 
B  DX2  (N)  322220077790111  H0003030091 
B  DX2  (O)  310100031340111  H0004040092 
B  DX2  (P)  310100038410111  H0004040093 
B  DX2  (Q)  310100044450111  H0002020094 
B  DX2  (R)  310100047510111  H0005050095 
B  DX2  (S)  310100053540111  H0002020096 
B  DX2  (T)  310100057580111  H0002020097 
B  DX2  (U)  310100061640111  H0004040098 
//EOF0552 
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680  PHYSICAL  THERAPY 

H03830247NY0051PHYSICAL  THERAPY 
H010221 


SCAN680.FIL 


LITHO 
UCA  PFX 
UCA  CODE  1 
UCA  CODE  2 
OTHER  UCA  1 
OTHER  UCA  2 
DATE  (MO) 
DATE  (DY)1 
DATE  (DY)2 
PROVl  PFXl 
PROVl  PFX2 
PROVl  CODE 
SSN 
FMP 

VISIT  COUNT 
PROVl  TIME 
PROV2  PFXl 
PROV2  PFX2 
PROV2  CODE 
PROV2  TIME 


739160104040011  H0024080001 
801  010002 

801  010003 

802  020004 
217170081810009  V0001000005 
2121200818100024V0001010006 
2434300574601014V0012020007 
1454500555201014V0004010008 
1444400554601014V0010010009 
044440033200109  V0014000010 
0434300322001014V0013010011 
1423901332401014V0040040012 
1332501554601014V0090090013 
1373601554601014V0020020014 
2141400544601024V0009010015 
2 3737003 51401014V0022020016 
029290033200109  V0014000017 
0282800322001024V0013010018 
1272401332401024V0040040019 


B  PROV2  TIME  2313100351401024V0022020020 
BREASON  FOR  #2  (1)  230300011090109  V0003000021 
BREASON  FOR  #2  (2)  227250108080009  H0003000022 
BREASON  FOR  #2  (CO) 2303000121200024V0001010023 
B  IF  NOT  SCHED  2171700717001024V0002010024 
BIF  NOT  CLINIC  (1)  217170063610109  V0003000025 
BIF  NOT  CLINIC  (2)  2141201606000024H0003010026 
B  REF  CODE  PFX  2040400706002024V0006010027 
B  REF  CODE  1  0030300716001024V0012010028 
B  REF  CODE  2  0020101714501024V0054020029 
B  JOB  RELATED  217170032320011  V0001010030 
B  MIL  ONLY  DUTY  2202000241410024V0002010031 
B  MIL  ONLY  QTRS  2191900222001024V0003010032 
B  MIL  ONLY  PROF  2191900181501024V0004010033 
B  REF  CODE  SING  2090900704501024V0026020034 
F  FILLER  803  030035 
B  SPEC  PRE  CLIN  306060022140111  H0009090036 
B  NOT  AVAILABLE  320200009070111  H0003030037 


MIL  ONLY  PROF 
REF  CODE  SING 
FILLER 

SPEC  PRE  CLIN 
NOT  AVAILABLE 


BPROV2  ADDLl  (YES)  208080006060011  V0001010038 


ADDL  PROCl 


1110701071601024V0050050039 


BPROV2  ADDL2  (YES)  202020006060011  V0001010040 


B  ADDL  PROC2  1050101071601024V0050050041 
F  ADMITTED  801  010042 
BUNL  REAS  PRIM  PFX  2121200747602024V0002010043 
B  UNL  REAS  PRIM  1110701748301034V0050050044 
B  UNL  REAS  SEC  PFX  2060600747602024V0002010045 


UNL  REAS  SEC 
FOLLOW/R  OUT 
PROC  PROVl  (A) 
PROC  PROVl  (B) 
PROC  PROVl  (C) 
PROC  PROVl  (D) 


1050101748301034V0050050046 
2383800393801024V0002010047 
335350008200111  H0013130048 
335350023300111  H0008080049 
323230008130111  H0006060050 
323230015350111  H0021210051 
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B  PROC  PROVl  (E)  311110019350111  H0017170052 

'  B  PROC  PROV2  (A)  334340008200111  H0013130053 

B  PROC  PROV2  (B)  334340023300111  H0008080054 

B  PROC  PROV2  (C)  322220008130111  H0006060055 

B  PROC  PROV2  (D)  322220015350111  H0021210056 

B  PROC  PROV2  (E)  310100019350111  H0017170057 

B  OTHER  CODES  347470006240111  H0019190058 
B  DXl  COLl  2474700437901024V0037020059 

B  DXl  COL2  (A)  235350041490109  V0009000060 

B  DXl  COL2  (B)  235350052540109  V0003000061 

B  DXl  COL2  (C)  235350056650109  V0010000062 

B  DXl  COL2  (D)  235350067680109  V0002000063 

B  DXl  COL2  (E)  2353500718001024V0010020064 

B  DXl  COL3  2232300415701024V0017020065 

BDXl  COL4  (A)  211110041460109  V0006000066 

BDXl  COL4  (B)  211110049490009  V0001000067 

BDXl  COL4  (C)  211110052530109  V0002000068 

BDXl  COL4  (D)  211110056560009  V0001000069 

BDXl  COL4  (E)  2111100585901024V0002010070 

B  DX2  (A)  346460043790111  H0037370071 

B  DX2  (B)  334340041490111  H0009090072 

B  DX2  (C)  334340052540111  H0003030073 

B  DX2  (D)  334340056650111  H0010100074 

B  DX2  (E)  334340067680111  H0002020075 

B  DX2  (F)  334340071800111  H0010100076 

B  DX2  (G)  322220041570111  H0017170077 

B  DX2  (H)  310100041460111  H0006060078 

(,•  B  DX2  (I)  310100049490011  H0001010079 

B  DX2  (J)  310100052530111  H0002020080 

B  DX2  (K)  310100056560011  H0001010081 

//EOF0593 
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690  PLASTIC  SURGERY 


SCAN690.FIL 


H03830247Ny0051PLASTIC  SURGERY 
H010241 


B 

LITHO 

B 

UCA 

PFX 

B 

UCA  CODE  1 

B 

UCA  CODE  2 

F 

OTHER  UCA 

B 

DATE 

(MO) 

B 

DATE 

(DY)1 

B 

DATE 

(DY)  2 

B 

PROVl 

PFXl 

B 

PRO  VI 

PFX2 

B 

PROVl 

CODE 

B 

SSN 

B 

FMP 

B 

VISIT 

COUNT 

B 

PROVl 

TIME 

B 

PROV2 

PFXl 

B 

PROV2 

PFX2 

B 

PROV2 

CODE 

B 

PROV2 

TIME 

BREASON  FOR  #2  (1) 
BREASON  FOR  #2  (2) 
B  IF  NOT  SCHED 
BIF  NOT  CLINIC  (1) 
BIF  NOT  CLINIC  (2) 


* 
* 

739160104040011  H0024080001 
2090900706202024V0005010002 
00808007 16001024V0012010003 
0070601714501024V0054020004 
801  010005 
2434300574601014V0012020006 
1454500555201014V0004010007 
1444400554601014V0010010008 
044440033200109  V0014000009 
0434300322001014V0013010010 
1423901332401014V0040040011 
1332501554601014V0090090012 
1373601554601014V0020020013 
2 14 1400544 601024V0009010014 
2373700351401014V0022020015 
029290033200109  V0014000016 
0282800322001024V0013010017 
1272401332401024V0040040018 
2313100351401024V0022020019 
230300011090109  V0003000020 
2272501080800024H0003010021 
2171700717001024V0002010022 
217170063610109  V0003000023 
2141201606000024H0003010024 
2040400706002024V0006010025 
0030300716001024V0012010026 
002 01017 14501024V0054020027 
217170032320011  V0001010028 
2202000241410024V0002010029 
2191900222001024V0003010030 
2191900181501024V0004010031 
805  050032 
306060022140111  H0009090033 
320200009070111  H0003030034 
208080006060011  V0001010035 
1110701071601024V0050050036 
202020006060011  V0001010037 
1050101071601024V0050050038 


B  REF  CODE  PFX 
B  REF  CODE  1 

B  REF  CODE  2 

B  JOB  RELATED 
B  MIL  ONLY  DUTY 

B  MIL  ONLY  QTRS 

B  MIL  ONLY  PROF 

t  FILLER 

B  SPEC  PRE  CLIN 

B  NOT  AVAILABLE 
BPROV2  ADDLl  (YES) 

B  ADDL  PROCl 

BPROV2  ADDL2  (YES) 

B  ADDL  PROC2 

B  ADMITTED  223230008080011  V0001010039 

BUNL  REAS  PRIM  PFX  2121200747602024V0002010040 
B  UNL  REAS  PRIM  1110701748301034V0050050041 
B  UNL  REAS  SEC  PFX  2060600747602024V0002010042 


B  UNL  REAS  SEC 
B  FOLLOW/R  OUT 


1050101748301034V0050050043 
2 3 8380027260102 4V0002010044 


B 

PROC 

PROVl 

(A) 

347470008100111 

H0003030045 

B 

PROC 

PROVl 

(B) 

347470012130111 

H0002020046 

B 

PROC 

PROVl 

(C) 

347470015150011 

H0001010047 

B 

PROC 

PROVl 

(D) 

347470018190111 

H0002020048 

B 

PROC 

PROVl 

(E) 

347470021210011 

H0001010049 

B 

PROC 

PROVl 

(F) 

335350008100111 

H0003030050 

B 

PROC 

PROVl 

(G) 

335350012210111 

H0010100051 

-A 
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B 

PROC 

:  PROV2  (A) 

346460008100111 

H0003030052 

B 

PROC 

:  PROV2  (B) 

346460012130111 

H0002020053 

B 

PROC 

:  PROV2  (C) 

346460015150011 

H0001010054 

B 

PROC 

:  PROV2  (D) 

346460018190111 

H0002020055 

B 

PROC  PROV2  (E) 

346460021210011 

H0001010056 

B 

PROC 

:  PROV2  (F) 

334340008100111 

H0003030057 

B 

PROC 

:  PROV2  (G) 

334340012210111 

H0010100058 

B 

DXl 

COLl 

(A) 

247470032330109 

V0002000059 

B 

DXl 

COLl 

(B) 

247470035370109 

V0003000060 

B 

DXl 

COLl 

(C) 

247470041470109 

V0007000061 

B 

DXl 

COLl 

(D) 

247470050520109 

V0003000062 

B 

DXl 

COLl 

(E) 

247470054570109 

V0004000063 

B 

DXl 

COLl 

(F) 

2474700616301024V0003020064 

B 

DXl 

COL2 

(A) 

235350029290009 

V0001000065 

B 

DXl 

COL2 

(B) 

235350031330109 

V0003000066 

B 

DXl 

COL2 

(C) 

235350036410109 

V0006000067 

B 

DXl 

COL2 

(D) 

235350045490109 

V0005000068 

B 

DXl 

COL2 

(E) 

2 3 535005263 01024V0012020069 

B 

DXl 

COL3 

(A) 

223230029320109 

V0004000070 

B 

DXl 

COL3 

(B) 

223230035350009 

V0001000071 

B 

DXl 

COL3 

(C) 

223230038420109 

V0005000072 

B 

DXl 

COL3 

(D) 

223230044460109 

V0003000073 

B 

DXl 

COL3 

(E) 

223230049550109 

V0007000074 

B 

DXl 

COL3 

(F) 

223230057590109 

V0003000075 

B 

DXl 

COL3 

(G) 

2232300616301024V0003020076 

B 

DXl 

COL4 

(A) 

211110029370109 

V0009000077 

B 

DXl 

COL4 

(B) 

211110040450109 

V0006000078 

B 

DXl 

COL4 

(C) 

211110048510109 

V0004000079 

B 

DXl 

COL4 

(D) 

211110053560109 

V0004000080 

B 

DXl 

COL4 

(E) 

211110058590109 

V0002000081 

B 

DXl 

COL4 

(F) 

2111100626200024V0001020082 

B 

DX2 

(A) 

346460032330111 

H0002020083 

B 

DX2 

(B) 

346460035370111 

H0003030084 

B 

DX2 

(C) 

346460041470111 

H0007070085 

B 

DX2 

(D) 

346460050520111 

H0003030086 

B 

DX2 

(E) 

346460054570111 

H0004040087 

B 

DX2 

(F) 

346460061630111 

H0003030088 

B 

DX2 

(G) 

334340029290011 

H0001010089 

B 

DX2 

(H) 

334340031330111 

H0003030090 

B 

DX2 

(I) 

334340036410111 

H0006060091 

B 

DX2 

(J) 

334340045490111 

H0005050092 

B 

DX2 

(K) 

334340052630111 

H0012120093 

B 

DX2 

(L) 

322220029320111 

H0004040094 

B 

DX2 

(M) 

322220035350011 

H0001010095 

B 

DX2 

(N) 

322220038420111 

H0005050096 

B 

DX2 

(0) 

322220044460111 

H0003030097 

B 

DX2 

(P) 

322220049550111 

H0007070098 

B 

DX2 

(Q) 

322220057590111 

H0003030099 

B 

DX2 

(R) 

322220061630111 

H0003030100 

B 

DX2 

(S) 

310100029370111 

H0009090101 

B 

DX2 

(T) 

310100040450111 

H0006060102 

B 

DX2 

(U) 

310100048510111 

H0004040103 

B 

DX2 

(V) 

310100053560111 

H0004040104 

B 

DX"’ 

(W) 

310100058590111 

H0002020105 

//EOF0489 
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700  PODIATRY 


SCAN700.FIL 


H03830247NY0051PODIATRY  * 

H010234  * 

B  LITHO  739160104040011  H0024080001 

B  UCA  PFX  2090900706202024V0005010002 

B  UCA  CODE  1  0080800716001024V0012010003 

B  UCA  CODE  2  0070601714501024V0054020004 

F  OTHER  UCA  801  010005 

B  DATE  (MO)  2434300574601014V0012020006 

B  DATE  (DY)1  1454500555201014V0004010007 

B  DATE  (DY)2  1444400554601014V0010010008 

B  PROVl  PFXl  044440033200109  V0014000009 

B  PROVl  PFX2  0434300322001014V0013010010 

B  PROVl  CODE  1423901332401014V0040040011 

B  SSN  1332501554601014V0090090012 

B  FMP  1373601554601014V0020020013 

B  VISIT  COUNT  2141400544601024V0009010014 

B  PROVl  TIME  2373700351401014V0022020015 

B  PROV2  PFXl  029290033200109  V0014000016 

B  PROV2  PFX2  0282800322001024V0013010017 

B  PROV2  CODE  1272401332401024V0040040018 

B  PROV2  TIME  2313100351401024V0022020019 

BREASON  FOR  #2  (1)  230300011090109  V0003000020 

BREASON  FOR  #2  (2)  2272501080800024H0003010021 

B  IF  NOT  SCHED  2171700717001024V0002010022 

BIF  NOT  CLINIC  (1)  217170063610109  V0003000023  • 

BIF  NOT  CLINIC  (2)  2141201606000024H0003010024 

B  REF  CODE  PFX  2040400706002024V0006010025 

B  REF  CODE  1  0030300716001024V0012010026 

B  REF  CODE  2  0020101714501024V0054020027 

B  JOB  RELATED  217170032320011  V0001010028 

B  MIL  ONLY  DUTY  2202000241410024V0002010029 

B  MIL  ONLY  QTRS  2191900222001024V0003010030 

B  MIL  ONLY  PROF  2191900181501024V0004010031 

F  FILLER  805  050032 

B  SPEC  PRE  CLIN  306060022140111  H0009090033 

B  NOT  AVAILABLE  320200009070111  H0003030034 

BPROV2  ADDLl  (YES)  208080006060011  V0001010035 

B  ADDL  PROCl  1110701071601024V0050050036 

BPROV2  ADDL2  (YES)  202020006060011  V0001010037 

B  ADDL  PROC2  1050101071601024V0050050038 

B  ADMITTED  211110027270011  V0001010039 

BUNL  REAS  PRIM  PFX  2121200747602024V0002010040 

B  UNL  REAS  PRIM  1110701748301034V0050050041 

B  UNL  REAS  SEC  PFX  2060600747602024V0002010042 

B  UNL  REAS  SEC  1050101748301034V0050050043 

B  FOLLOW/R  OUT  2383800333201024V0002010044 

B  PROC  PROVl  (A)  347470008150111  H0008080045 

B  PROC  PROVl  (B)  347470018240111  H0007070046 

B  PROC  PROVl  (C)  335350008090111  H0002020047 

B  PROC  PROVl  (D)  335350011130111  H0003030048 

B  PROC  PROVl  (E)  335350016230111  H0008080049 

B  PROC  PROVl  (F)  335350025250011  H0001010050 

B  PROC  PROVl  (G)  323230008190111  H0012120051 
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B 

PROC 

PROVl 

(H) 

323230022240111 

H0003030052 

B 

PROC 

PROVl 

(I) 

323230027290111 

H0003030053 

B 

PROC 

PROVl 

(J) 

311110020200011 

H0001010054 

B 

PROC 

PROVl 

(K) 

311110022240111 

H0003030055 

B 

PROC 

PROV2 

(A) 

346460008150111 

H0008080056 

B 

PROC 

PROV2 

(B) 

346460018240111 

H0007070057 

B 

PROC 

PROV2 

(C) 

334340008090111 

H0002020058 

B 

PROC 

PROV2 

(D) 

334340011130111 

H0003030059 

B 

PROC 

PROV2 

(E) 

334340016230111 

H0008080060 

B 

PROC 

PROV2 

(F) 

334340025250011 

H0001010061 

B 

PROC 

PROV2 

(G) 

322220008190111 

H0012120062 

B 

PROC 

PROV2 

(H) 

322220022240111 

H0003030063 

B 

PROC 

PROV2 

(I) 

322220027290111 

H0003030064 

B 

PROC 

PROV2 

(J) 

310100020200011 

H0001010065 

B 

PROC 

PROV2 

(K) 

310100022240111 

H0003030066 

B 

DXl 

COLl 

(A) 

247470037510109 

V0015000067 

B 

DXl 

COLl 

(B) 

247470053530009 

V0001000068 

B 

DXl 

COLl 

(C) 

2474700555601024V0002020069 

B 

DXl 

COL2 

(A) 

235350035500109 

V0016000070 

B 

DXl 

COL2 

(B) 

2353500527701024V0026020071 

B 

DXl 

COL3 

(A) 

223230035440109 

V0010000072 

B 

DXl 

COL3 

(B) 

223230046480109 

V0003000073 

B 

DXl 

COL3 

(C) 

223230052640109 

V0013000074 

B 

DXl 

COL3 

(D) 

223230066710109 

V0006000075 

B 

DXl 

COL3 

(E) 

211110035350009 

V0001000076 

B 

DXl 

COL3 

(F) 

211110037410109 

V0005000077 

B 

DXl 

COL3 

(G) 

2111100434300024V0001020078 

B 

DX2 

(A) 

346460037510111 

H0015150079 

B 

DX2 

(B) 

346460053530011 

H0001010080 

B 

DX2 

(C) 

346460055560111 

H0002020081 

B 

DX2 

(D) 

334340035500111 

H0016160082 

B 

DX2 

(E) 

334340052770111 

H0026260083 

B 

DX2 

(F) 

322220035440111 

H0010100084 

B 

DX2 

(G) 

322220046480111 

H0003030085 

B 

DX2 

(H) 

322220052640111 

H0013130086 

B 

DX2 

(I) 

322220066710111 

H0006060087 

B 

DX2 

(J) 

310100035350011 

H0001010088 

B 

DX2 

(K) 

310100037410111 

H0005050089 

//EOF0545 
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710  PREVENTIVE  MEDICINE 


SCAN710.FIL 


H03830247NY0051PREVENTIVE  MEDICINE  * 
H010229  * 
B  LITHO  739160104040011  H0024080001 
B  UCA  PFX  2090900706202024V0005010002 
B  UCA  CODE  1  0080800716001024V0012010003 
B  UCA  CODE  2  0070601714501024V0054020004 
B  OTHER  UCA  1  217170081810009  V0001000005 
B  OTHER  UCA  2  2121200818100024V0001010006 
B  DATE  (MO)  2434300574601014V0012020007 
B  DATE  (DY)1  1454500555201014V0004010008 
B  DATE  (DY)2  1444400554601014V0010010009 
B  PROVl  PFXl  044440033200109  V0014000010 
B  PROVl  PFX2  0434300322001014V0013010011 
B  PROVl  CODE  1423901332401014V0040040012 
B  SSN  1332501554601014V0090090013 
B  FMP  1373601554601014V0020020014 
B  VISIT  COUNT  2141400544601024V0009010015 
B  PROVl  TIME  2373700351401014V0022020016 
B  PROV2  PFXl  029290033200109  V0014000017 
B  PROV2  PFX2  0282800322001024V0013010018 
B  PROV2  CODE  1272401332401024V0040040019 
B  PROV2  TIME  2313100351401024V0022020020 
BREASON  FOR  #2  (1)  230300011090109  V0003000021 
BREASON  FOR  #2  (2)  2272501080800024H0003010022 
B  IF  NOT  SCHED  2171700717001024V0002010023 
BIF  NOT  CLINIC  (1)  217170063610109  V0003000024 
BIF  NOT  CLINIC  (2)  2141201606000024H0003010025 
B  REF  CODE  PFX  2040400706002024V0006010026 
B  REF  CODE  1  0030300716001024V0012010027 
B  REF  CODE  2  0020101714501024V0054020028 
B  JOB  RELATED  217170032320011  V0001010029 
B  MIL  ONLY  DUTY  2202000241410024V0002010030 
B  MIL  ONLY  QTRS  2191900222001024V0003010031 
B  MIL  ONLY  PROF  2191900181501024V0004010032 
F  FILLER  805  050033 
B  SPEC  PRE  CLIN  306060022140111  H0009090034 
B  NOT  AVAILABLE  320200009070111  H0003030035 
BPROV2  ADDLl  (YES)  208080006060011  V0001010036 
B  ADDL  PROCl  1110701071601024V0050050037 
BPROV2  ADDL2  (YES)  202020006060011  V0001010038 
B  ADDL  PROC2  1050101071601024V0050050039 
F  ADMITTED  801  010040 
BUNL  REAS  PRIM  PFX  2121200747602024V0002010041 
B  UNL  REAS  PRIM  1110701748301034V0050050042 
B  UNL  REAS  SEC  PFX  2060600747602024V0002010043 
B  UNL  REAS  SEC  1050101748301034V0050050044 
B  FOLLOW/R  OUT  2383800363501024V0002010045 
B  PROC  PROVl  (A)  347470008170111  H0010100046 
B  PROC  PROVl  (B)  347470020290111  H0010100047 
B  PROC  PROVl  (C)  335350008100111  H0003030048 
B  PROC  PROVl  (D)  335350013320111  H0020200049 
B  PROC  PROVl  (E)  323230008140111  H0007070050 
B  PROC  PROVl  (F)  323230017220111  H0006060051 
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B  PROC  PROV2  (A) 
B  PROC  PROV2  (B) 
B  PROC  PROV2  (C) 
B  PROC  PROV2  (D) 
B  PROC  PROV2  (E) 
B  PROC  PROV2  (F) 


346460008170111  H0010100052 
346460020290111  H0010100053 
334340008100111  H0003030054 
334340013320111  H0020200055 
322220008140111  H0007070056 
322220017220111  H0006060057 


BDXl 

COLl 

(A) 

247470040490109 

V0010000058 

BDXl 

COLl 

(B) 

247470052580109 

V0007000059 

BDXl 

COLl 

(C) 

247470060680109 

V0009000060 

BDXl 

COLl 

(D) 

247470071720109 

V0002000061 

BDXl 

COLl 

(E) 

247470075760109 

V0002000062 

BDXl 

COLl 

(F) 

2474700798001024V0002 020063 

BDXl 

COL2 

(A) 

235350038390109 

V0002000064 

BDXl 

COL2 

(B) 

235350043460109 

V0004000065 

BDXl 

COL2 

(C) 

235350049530109 

V0005000066 

BDXl 

COL2 

(D) 

235350056630109 

V0008000067 

BDXl 

COL2 

(E) 

235350066700109 

V0005000068 

BDXl 

COL2 

(F) 

235350073760109 

V0004000069 

BDXl 

COL2 

(G) 

2353500798101024V0003020070 

BDXl 

COL3 

(A) 

223230038420109 

V0005000071 

BDXl 

COL3 

(B) 

223230045490109 

V0005000072 

BDXl 

COL3 

(C) 

223230052730109 

V0022000073 

BDXl 

COL3 

(D) 

223230075750009 

V0001000074 

BDXl 

COL3 

(E) 

22323007777 00024V000102007 5 

BDXl 

COL4 

(A) 

211110037370009 

V0001000076 

BDXl 

COL4 

(B) 

211110039390009 

V00010C0077 

BDXl 

COL4 

(C) 

211110041410009 

V0001000078 

BDXl 

COL4 

(D) 

211110043450109 

V0003000079 

BDXl 

COL4 

(E) 

211110047470009 

V0001000080 

BDXl 

COL4 

(F) 

211110049550109 

V0007000081 

BDXl 

COL4 

(G) 

211110058610109 

V0004000082 

BDXl 

COL4 

(H) 

2111100636401024V0002020083 

B 

DX2 

(A) 

346460040490111 

H0010100084 

B 

DX2 

(B) 

346460052580111 

H0007070085 

B 

DX2 

(C) 

346460060680111 

H0009090086 

B 

DX2 

(D) 

346460071720111 

H0002020087 

B 

DX2 

(E) 

346460075760111 

H0002020088 

B 

DX2 

(F) 

346460079800111 

H0002020089 

B 

DX2 

(G) 

334340038390111 

H0002020090 

B 

DX2 

(H) 

334340043460111 

H0004040091 

B 

DX2 

(I) 

334340049530111 

H0005050092 

B 

DX2 

(J) 

334340056630111 

H0008080093 

B 

DX2 

(K) 

334340066700111 

H0005050094 

B 

DX2 

(L) 

334340073760111 

H0004040095 

B 

DX2 

(M) 

334340079810111 

H0003030096 

B 

DX2 

(N) 

322220038420111 

H0005050097 

B 

DX2 

(0) 

322220045490111 

H0005050098 

B 

DX2 

(P) 

322220052730111 

H0022220099 

B 

DX2 

(Q+ 

322220075750011 

HOOOlOlOlOO 

B 

DX2 

(R) 

322220077770011 

HOOOIOIOIOI 

B 

DX2 

(S) 

310100037370011 

H0001010102 

B 

DX2 

(T) 

310100039390011 

H0001010103 

B 

DX2 

(U) 

310100041410011 

H0001010104 

B 

LJ:. 

'V) 

310100043450111 

H0003030105 

B 

r)X2 

(W) 

310100047470011 

H0001010106 
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a  00 


DX2  (X)  310100049550111  H0007070107 

DX2  (Y)  310100058610111  H0004040108 

//EOF0572 
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720  PRIMARY  CARE 


SCAN720.FIL 


H03830247NY0051PRIMARY  CARE  * 
H010240  * 
B  LITHO  739160104040011  H0024080001 
B  UCA  PFX  2090900706202024V0005010002 
B  UCA  CODE  1  0080800716001024V0012010003 
B  UCA  CODE  2  0070601714501024V0054020004 
B  OTHER  UCA  217170081810009  V0001000005 
B  OTHER  UCA  1  2121200818100024V0001010006 
B  DATE  (MO)  2434300574601014V0012020007 
B  DATE  (DY)1  1454500555201014V0004010008 
B  DATE  (DY)2  1444400554601014V0010010009 
B  PROVl  PFXl  044440033200109  V0014000010 
B  PROVl  PFX2  0434300322001014V0013010011 
B  PROVl  CODE  1423901332401014V0040040012 
B  SSN  1332501554601014V0090090013 
B  FMP  1373601554601014V0020020014 
B  VISIT  COUNT  2141400544601024V0009010015 
S  PROVl  TIME  2373700351401014V0022020016 
B  PROV2  PFXl  029290033200109  V0014000017 
B  PROV2  PFX2  0282800322001024V0013010018 
B  PROV2  CODE  1272401332401024V0040040019 
B  PROV2  TIME  2313100351401024V0022020020 
BREASON  FOR  #2  (1)  230300011090109  V0003000021 
BREASON  FOR  #2  (2)  2272501080800024H0003010022 
B  IF  NOT  SCHED  2171700717001024V0002010023 
BIF  NOT  CLINIC  (1)  217170063610109  V0003000024 
BIF  NOT  CLINIC  (2)  2141201606000024H0003010025 
B  REF  CODE  PFX  2040400706002024V0006010026 
B  REF  CODE  1  0030300716001024V0012010027 
B  REF  CODE  2  0020101714501024V0054020028 
B  JOB  RELATED  217170032320011  V0001010029 
B  MIL  ONLY  DUTY  2202000241410024V0002010030 
B  MIL  ONLY  QTRS  2191900222001024V0003010031 
B  MIL  ONLY  PROF  2191900181501024V0004010032 
F  FILLER  805  050033 
B  SPEC  PRE  CLIN  306060022140111  H0009090034 
B  NOT  AVAILABLE  320200009070111  H0003030035 
BPROV2  ADDLl  (YES)  208080006060011  V0001010036 
B  ADDL  PROCl  1110701071601024V0050050037 
BPROV2  ADDL2  (YES)  202020006060011  V0001010038 
B  ADDL  PROC2  1050101071601024V0050050039 
B  ADMITTED  247470020200011  V0001010040 
BUNL  REAS  PRIM  PFX  2121200747602024V0002010041 
B  UNL  REAS  PRIM  1110701748301034V0050050042 
B  UNL  REAS  SEC  PFX  2060600747602024V0002010043 
B  UNL  REAS  SEC  1050101748301034V0050050044 
B  FOLLOW/R  OUT  2383800272601024V0002010045 
B  PROC  PROVl  347470007180111  H0012120046 
B  PROC  PROV2  346460007180111  H0012120047 
B  DXl  COLl  (A)  247470031350109  V0005000048 
B  DXl  COLl  (B)  247470038410109  V0004000049 
B  DXl  COLl  (C)  247470043450109  V0003000050 
B  DXl  COLl  (D)  247470047490109  V0003000051 


B 

DXl 

COLl 

(E) 

2A7A70051530109 

V0003000052 

B 

DXl 

COLl 

(F) 

247A70056610109 

V0006000053 

B 

DXl 

COLl 

(G) 

247A70064730102AV001002005A 

B 

DXl 

COL2 

(A) 

235350030310109 

V0002000055 

B 

DXl 

COL2 

(B) 

235350033350109 

V0003000056 

B 

DXl 

COL2 

(C) 

235350038440109 

V0007000057 

B 

DXl 

COL2 

(D) 

235350047500109 

V0004000058 

B 

DXl 

COL2 

(E) 

2353500536501024V0013020059 

B 

DXl 

COL3 

(A) 

223230029340109 

V0006000060 

B 

DXl 

COL3 

(B) 

223230037410109 

V0005000061 

B 

DXl 

COL3 

(C) 

223230044450109 

V0002000062 

B 

DXl 

COL3 

(D) 

223230049490009 

V0001000063 

B 

DXl 

COL3 

(E) 

223230051540109 

V0004000064 

B 

DXl 

COL3 

(F) 

223230056620109 

V0007000065 

B 

DXl 

COL3 

(G) 

2232300646601024V0003020066 

B 

DXl 

COLA 

(A) 

211110029290009 

V0001000067 

B 

DXl 

COLA 

(B) 

211110031310009 

V0001000068 

B 

DXl 

COLA 

(C) 

211110033330009 

V0001000069 

B 

DXl 

COLA 

(D) 

211110036360009 

V0001000070 

B 

DXl 

COLA 

(E) 

211110038380009 

V0001000071 

B 

DXl 

COLA 

(F) 

211110041430109 

V0003000072 

B 

DXl 

COLA 

(G) 

211110045460109 

V0002000073 

B 

DXl 

COLA 

(H) 

211110049510109 

V0003000074 

B 

DXl 

COLA 

(I) 

2111100535401024V0002020075 

B 

DX2 

(A) 

346460031350111 

H0005050076 

B 

DX2 

(B) 

346460038410111 

H0004040077 

B 

DX2 

(C) 

346460043450111 

H0003030078 

B 

DX2 

(D) 

346460047490111 

H0003030079 

B 

DX2 

(E) 

346460051530111 

H0003030080 

B 

DX2 

(F) 

346460056610111 

H0006060081 

B 

DX2 

(G) 

346460064730111 

H0010100082 

B 

DX2 

(H) 

334340030310111 

H0002020083 

B 

DX2 

(I) 

334340033350111 

H0003030084 

B 

DX2 

(J) 

334340038440111 

H0007070085 

B 

DX2 

(K) 

334340047500111 

H0004040086 

B 

DX2 

(L) 

334340053650111 

H0013130087 

B 

DX2 

(M) 

322220029340111 

H0006060088 

B 

DX2 

(N) 

322220037410111 

H0005050089 

B 

DX2 

(0) 

322220044450111 

H0002020090 

B 

DX2 

(P) 

322220049490011 

H0001010091 

B 

DX2 

(Q) 

322220051540111 

H0004040092 

B 

DX2 

(R) 

322220056620111 

H0007070093 

B 

DX2 

(S) 

322220064660111 

H0003030094 

B 

DX2 

(T) 

310100029290011 

H0001010095 

B 

DX2 

(U) 

310100031310011 

H0001010096 

B 

DX2 

(V) 

310100033330011 

H0001010097 

B 

DX2 

(W) 

310100036360011 

H0001010098 

B 

DX2 

(X) 

310100038380011 

H0001010099 

B 

DX2 

(V) 

310100041430111 

H0003030100 

B 

DX2 

(Z) 

310100045460111 

H0002020101 

B 

DX2 

(AA) 

310100049510111 

H0003030102 
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730  PSYCHIATRY 


SCAN730.FIL 


H03830247NY0051PSYCHIATRY  * 
H020444  * 
B  LITHO  739160104040011  H0024080001 
B  UCA  PFX  2090900706202024V0005010002 
B  UCA  CODE  1  0080800716001024V0012010003 
B  UCA  CODE  2  0070601714501024V0054020004 
B  OTHER  UCA  1  217170081810009  V0001000005 
B  OTHER  UCA  2  2121200818100024V0001010006 
B  DATE  (MO)  2434300574601014V0012020007 
B  DATE  (DY)1  1454500555201014V0004010008 
B  DATE  (DY)2  1444400554601014V0010010009 
B  PROVl  PFXl  0444400332G0109  V0014000010 
B  PROVl  PFX2  0434300322001014V0013010011 
B  PROVl  CODE  1423901332401014V0040040012 
B  SSN  1332501554601014V0090090013 
B  FMP  1373601554601014V0020020014 
B  VISIT  COUNT  2141400544601024V0009010015 
B  PROVl  TIME  2373700351401014V0022020016 
B  PROV2  PFXl  029290033200109  V0014000017 
B  PROV2  PFX2  0282800322001024V0013010018 
B  PROV2  CODE  1272401332401024V0040040019 
B  PROV2  TIME  2313100351401024V0022020020 
BREASON  FOR  #2  (1)  230300011090109  V0003000021 
BREASON  FOR  #2  (2)  227250108080009  H0003000022 
BREASON  FOR  #2  (CO) 2303000121200024V0001010023 
B  IF  NOT  SCHED  2171700717001024V0002010024 
BIF  NOT  CLINIC  (1)  217170063610109  V0003000025 
BIF  NOT  CLINIC  (2)  2141201606000024H0003010026 
B  REF  CODE  PFX  2040400706002024V0006010027 
B  REF  CODE  1  0030300716001024V0012010028 
B  REF  CODE  2  0020101714501024V0054020029 
B  JOB  RELATED  217170032320011  V0001010030 
B  MIL  ONLY  DUTY  2202000241410024V0002010031 
B  MIL  ONLY  QTRS  2191900222001024V0003010032 
B  MIL  ONLY  PROF  2191900181501024V0004010033 
F  FILLER  805  050034 
B  SPEC  PRE  CLIN  306060022140111  H0009090035 
B  NOT  AVAILABLE  320200009070111  H0003030036 
BPROV2  ADDLl  (YES)  208080006060011  V0001010037 
B  ADDL  PROCl  1110701071601024V0050050038 
BPROV2  ADDL2  (YES)  202020006060011  V0001010039 
B  ADDL  PROC2  1050101071601024V0050050040 
B  ADMITTED  211110017170011  V0001010041 
BUNL  REAS  PRIM  PFX  2121200747602024V0002010042 
B  UNL  REAS  PRIM  1110701748301034V0050050043 
B  UNL  REAS  SEC  PFX  2060600747602024V0002010044 
B  UNL  REAS  SEC  1050101748301034V0050050045 
B  RULE  OUT  244440005050011  V0001010046 
B  PROC  PROVl  323230007160111  H0010100047 
B  PROC  PROV2  322220007160111  H0010100048 
BOTHER  CODES  (All)  311110036480111  H0013130049 
BOTHER  CC,  -ES  (AIII)  3 11110050500011  H0001010050 
BOTHER  CODES  (AIV)  311110052590111  H0008080051 
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BOTHER  CODES  (AV)  311110061680111  H0008080052 


B 

AXISl 

COLl 

(A) 

247470007080109 

V0002000053 

B 

AXISl 

COLl 

(B) 

247470011120109 

V0002000054 

B 

AXISl 

COLl 

(C) 

247470014170109 

V0004000055 

B 

AXISl 

COLl 

(D) 

247470019240109 

V0006000056 

B 

AXISl 

COLl 

(E) 

247470026270109 

V0002000057 

B 

AXISl 

COLl 

(F) 

247470029300109 

V0002000058 

B 

AXISl 

COLl 

(G) 

247470032360109 

V0005000059 

B 

AXISl 

COLl 

(H) 

247470038390109 

V0002000060 

B 

AXISl 

COLl 

(I) 

247470042470109 

V0006000061 

B 

AXISl 

COLl 

(J) 

247470051560109 

V0006000062 

B 

AXISl 

COLl 

(K) 

247470058640109 

V0007000063 

B 

AXISl 

COLl 

(L) 

247470066690109 

V0004000064 

B 

AXISl 

COLl 

(M) 

247470071780109 

V0008000065 

B 

AXISl 

COLl 

(N) 

2474700808301024V0004020066 

B 

AXISl 

COL2 

(A) 

235350006100109 

V0005000067 

B 

AXISl 

COL2 

(B) 

235350012290109 

V0018000068 

B 

AXISl 

COL2 

(C) 

235350033400109 

V0008000069 

B 

AXISl 

COL2 

(D) 

235350042460109 

V0005000070 

B 

AXISl 

COL2 

(E) 

235350053550109 

V0003000071 

B 

AXISl 

COL2 

(F) 

235350057600109 

V0004000072 

B 

AXISl 

COL2 

(G) 

235350062640109 

V0003000073 

B 

AXISl 

COL2 

(H) 

235350070710109 

V0002000074 

B 

AXISl 

COL2 

(I) 

235350079810109 

V0003000075 

B 

AXISl 

COL2 

(J) 

2353500838300024V0001020076 

B 

AXISl 

COL3 

(A) 

223230018260109 

V0009000077 

B 

AXISl 

COL3 

(B) 

223230028310109 

V0004000078 

B 

AXISl 

COL3 

(C) 

223230033360109 

V0004000079 

B 

AXISl 

COL3 

(D) 

223230038380009 

V0001000080 

B 

AXISl 

COL3 

(E) 

223230041410009 

V0001000081 

B 

AXISl 

COL3 

(F) 

223230043510109 

V0009000082 

6 

AXISl 

COL3 

(G) 

223230053600109 

V0008000083 

B 

AXISl 

COL3 

(H) 

223230062630109 

V0002000084 

B 

AXISl 

COL3 

(I) 

223230065700109 

V0006000085 

B 

AXISl 

COL3 

(J) 

223230072800109 

V0009000086 

B 

AXISl 

COL3 

(K) 

2232300828301024V0002020087 

B 

AXISl 

COLA 

2111100183101024V0014020088 

B 

ADDL 

AXISl 

(A) 

346460007080111 

H0002020089 

B 

ADDL 

AXISl 

(B) 

346460011120111 

H0002020090 

B 

ADDL 

AXISl 

(C) 

346460014170111 

H0004040091 

B 

ADDL 

AXISl 

(D) 

346460019240111 

H0006060092 

B 

ADDL 

AXISl 

(E) 

346460026270111 

H0002020093 

B 

ADDL 

AXISl 

(F) 

346460029300111 

H0002020094 

B 

ADDL 

AXISl 

(G) 

346460032360111 

H0005050095 

B 

ADDL 

AXISl 

(H) 

346460038390111 

H0002020096 

B 

ADDL 

AXISl 

(I) 

346460042470111 

H0006060097 

B 

ADDL 

AXISl 

(J) 

346460051560111 

H0006060098 

B 

ADDL 

AXISl 

(K) 

346460058640111 

H0007070099 

B 

ADDL 

AXISl 

(E) 

346460066690111 

H0004040100 

B 

ADDL 

AXISl 

(M) 

346460071780111 

H0008080101 

B 

ADDL 

AXISl 

(N) 

346460080830111 

H0004040102 

B 

ADDL 

AXISl 

(0) 

334340006100111 

H0005050103 

B 

ADDL 

AXISl 

(P) 

334340012290111 

H0018180104 

B 

ADDL 

AXISl 

(Q) 

334340033400111 

H0008080105 

B 

ADDL 

AXISl 

(R) 

334340042460111 

H0005050106 
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B  ADDL  AXISl  (S)  334340053550111  H0003030107 
B  ADDL  AXISl  (T)  334340057600111  H0004040108 
B  ADDL  AXISl  (U)  334340062640111  H0003030109 
B  ADDL  AXISl  (V)  334340070710111  H0002020110 
B  ADDL  AXISl  (W)  334340079810111  H0003030111 
B  ADDL  AXISl  (X)  334340083830011  H0001010112 
B  ADDL  AXISl  (Y)  322220018260111  H0009090113 
B  ADDL  AXISl  (Z)  322220028310111  H0004040114 
B  ADDL  AXISl  (AA)  322220033360111  H0004040115 
B  ADDL  AXISl  (BB)  322220038380011  H0001010116 
B  ADDL  AXISl  (CC)  322220041410011  H0001010117 
B  ADDL  AXISl  (DD)  322220043510111  H0009090118 
B  ADDL  AXISl  (EE)  322220053600111  H0008080119 
B  ADDL  AXISl  (FF)  322220062630111  H0002020120 
B  ADDL  AXISl  (GG)  322220065700111  H0006060121 
B  ADDL  AXISl  (HH)  322220072800111  H0009090122 
B  ADDL  AXISl  (II)  322220082830111  H0002020123 
B  ADDL  AXISl  (JJ)  310100018290111  H0012120124 
B  SPEC  PROG  (1)  307070035320111  H0004040125 
B  SPEC  PROG  (2)  304020131310011  V0003030126 
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740  PSYCHOLOGY 


SCAN740.FIL 


H03830247NY0051PSYCHOLOGY  * 
H020443  * 
B  LITHO  739160104040011  H0024080001 
B  UCA  PFX  2090900706202024V0005010002 
B  UCA  CODE  1  0080800716001024V0012010003 
B  UCA  CODE  2  0070601714501024V0054020004 
B  OTHER  UCA  1  217170081800109  V0002000005 
B  OTHER  UCA  2  2121200818100024V0001010006 
B  DATE  (MO)  2434300574601014V0012020007 
B  DATE  (DY)1  1454500555201014V0004010008 
B  DATE  (DY)2  1444400554601014V0010010009 
B  PROVl  PFXl  044440033200109  V0014000010 
B  PROVl  PFX2  0434300322001014V0013010011 
B  PROVl  CODE  1423901332401014V0040040012 
B  SSN  1332501554601014V0090090013 
B  FMP  1373601554601014V0020020014 
B  VISIT  COUNT  2141400544601024V0009010015 
B  PROVl  TIME  2373700351401014V0022020016 
B  PROV2  PFXl  029290033200109  V0014000017 
B  PROV2  PFX2  0282800322001024V0013010018 
B  PROV2  CODE  1272401332401024V0040040019 
B  PROV2  TIME  2313100351401024V0022020020 
BREASON  FOR  #2  (1)  230300011090109  V0003000021 
BREASON  FOR  #2  (2)  227250108080009  H0003000022 
BREASON  FOR  #2  (CO) 2303000121200024V0001010023 
B  IF  NOT  SCHED  2171700717001024V0002010024 
BIF  NOT  CLINIC  (1)  217170063610109  V0003000025 
BIF  NOT  CLINIC  (2)  2141201606000024H0003010026 
B  REF  CODE  PFX  2040400706002024V0006010027 
B  REF  CODE  1  0030300716001024V0012010028 
B  REF  CODE  2  0020101714501024V0054020029 
B  JOB  RELATED  217170032320011  V0001010030 
B  MIL  ONLY  DUTY  2202000241410024V0002010031 
B  MIL  ONLY  QTRS  2191900222001024V0003010032 
B  MIL  ONLY  PROF  2191900181501024V0004010033 
F  FILLER  805  050034 
B  SPEC  PRE  CLIN  306060022140111  H0009090035 
B  NOT  AVAILABLE  320200009070111  H0003030036 
BPROV2  ADDLl  (YES)  208080006060011  V0001010037 
B  ADDL  PROCl  1110701071601024V0050050038 
BPROV2  ADDL2  (YES)  202020006060011  V0001010039 
B  ADDL  PROC2  1050101071601024V0050050040 
F  ADMITTED  801  010041 
BUNL  REAS  PRIM  PFX  2121200747602024V0002010042 
B  UNL  REAS  PRIM  1110701748301034V0050050043 
B  UNL  REAS  SEC  PFX  2060600747602024V0002010044 
B  UNL  REAS  SEC  1050101748301034V0050050045 
B  RULE  OUT  242420022220011  V0001010046 
B  PROC  PROVl  (A)  347470007190111  H0013130047 
B  PROC  PROVl  (B)  335350006100111  H0005050048 
B  PROC  PROVl  (C)  335350014190111  H0006060049 
B  PROC  PROVl  (D)  323230006190111  H0014140050 
B  PROC  PROV2  (A)  346460007190111  H0013130051 
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B  PROC  PROV2  (B)  334340006100111  H0005050052 
B  PROC  PROV2  (C)  334340014190111  H0006060053 
B  PROC  PROV2  (D)  322220006190111  H0014140054 
BOTHER  CODES  (All) 1311110031330111  H0003030055 
BOTHER  CODES  (All) 2311110035480111  H0014140056 
BOTHER  CODES  (AIII) 311110050500011  H0001010057 
BOTHER  CODES  (AIV)  311110052590111  H0008080058 
BOTHER  CODES  ^V)  311110061680111  H0008080059 
B  AXISl  COLl  (A)  247470024290109  V0006000060 
B  AXISl  COLl  (B)  247470031330109  V0003000061 
B  AXISl  COLl  (C)  247470035390109  V0005000062 
B  AXISl  COLl  (D)  247470041540109  V0014000063 
B  AXISl  COLl  (E)  247470056610109  V0006000064 
B  AXISl  COLl  (F)  247470065740109  V0010000065 
B  AXISl  COLl  (G)  2474700768301024V0008020066 
B  AXISl  COL2  (A)  235350024400109  V0017000067 
B  AXISl  COL2  (B)  235350044480109  V0005000068 
B  AXISl  COL2  (C)  235350054560109  V0003000069 
B  AXISl  COL2  (D)  235350058610109  V0004000070 
B  AXISl  COL2  (E)  235350063650109  V0003000071 
B  AXISl  COL2  (F)  235350070710109  V0002000072 
B  AXISl  COL2  (G)  235350077800109  V0004000073 
B  AXISl  COL2  (H)  2353500828301024V0002020074 
B  AXISl  COL3  (A)  223230023350109  V0013000075 
B  AXISl  COL3  (B)  223230037400109  V0004000076 
B  AXISl  COL3  (C)  223230042510109  V0010000077 
B  AXISl  COL3  (D)  223230053550109  V0003000078 
B  AXISl  COL3  (E)  223230057600109  V0004000079 
B  AXISl  COL3  (F)  223230062700109  V0009000080 
B  AXISl  COL3  (G)  223230072830109  V0012000081 
B  AXISl  COL3  (H)  2111100232601024V0004020082 
B  ADDL  AXISl  (A)  346460024290111  H0006060083 
B  ADDL  AXISl  (B)  346460031330111  H0003030084 
B  ADDL  AXISl  (C)  346460035390111  H0005050085 
B  ADDL  AXISl  (D)  346460041540111  H0014140086 
B  ADDL  AXISl  (E)  346460056610111  H0006060087 
B  ADDL  AXISl  (F)  346460065740111  H0010100088 
B  ADDL  AXISl  (G)  346460076830111  H0008080089 
B  ADDL  AXISl  (H)  334340024400111  H0017170090 
B  ADDL  AXISl  (I)  334340044480111  H0005050091 
B  ADDL  AXISl  (J)  334340054560111  H0003030092 
B  ADDL  AXISl  (K)  334340058610111  H0004040093 
B  ADDL  AXISl  (L)  334340063650111  H0003030094 
B  ADDL  AXISl  (M)  334340070710111  H0002020095 
B  ADDL  AXISl  (N)  334340077800111  H0004040096 
B  ADDL  AXISl  (O)  334340082830111  H0002020097 
B  ADDL  AXISl  (P)  322220023350111  H0013130098 
B  ADDL  AXISl  (Q)  322220037400111  H0004040099 
B  ADDL  AXISl  (R)  322220042510111  HOOlOlOOlOO 
B  ADDL  AXISl  (S)  322220053550111  H0003030101 
B  ADDL  AXISl  (T)  322220057600111  H0004040102 
B  ADDL  AXISl  (U)  322220062700111  H0009090103 
B  ADDL  AXISl  (V)  322220072830111  H0012120104 
B  ADDL  AXTSl  (W)  310100023260111  H0004040105 
BPSYCHOMETRIC  \SSES311110018210111  H0004040106 
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B  SPEC  PROG  (1)  307070035320111  H0004040107 
B  SPEC  PROG  (2)  304020131310011  V0003030108 
//EOF0608 


750  PULMONARY 


SCAN750.FIL 


H03830247NY0051PULMONARY  * 

H010230  * 


B  LITHO 

B  UCA  PFX 

B  UCA  CODE  1 

B  UCA  CODE  2 

B  OTHER  UCA 

B  DATE  (MO) 

B  DATE  (DY)1 

B  DATE  (DY)2 

B  PROVl  PFXl 

B  PROVl  PFX2 

B  PROVl  CODE 

B  SSN 

B  FMP 

B  VISIT  COUNT 

B  PROVl  TIME 

B  PROV2  PFXl 

B  PROV2  PFX2 

B  PROV2  CODE 

B  PROV2  TIME 

BREASON  FOR  #2  (1) 
BREASON  FOR  #2  (2) 
B  IF  NOT  SCHED 
BIF  NOT  CLINIC  (1) 
V*  BIF  NOT  CLINIC  (2) 

B  REF  CODE  PFX 

B  REF  CODE  1 

B  REF  CODE  2 

B  JOB  RELATED 
B  MIL  ONLY  DUTY 

B  MIL  ONLY  QTRS 

B  MIL  ONLY  PROF 

F  FILLER 

B  SPEC  PRE  CLIN 

B  NOT  AVAILABLE 

BPROV2  ADDLl  (YES) 
B  ADDL  PROCl 

BPROV2  ADDL2  (YES) 
B  ADDL  PROC2 

B  ADMITTED 

BUNL  REAS  PRIM  PFX 
B  UNL  REAS  PRIM 

B  UNL  REAS  SEC  PFX 
B  UNL  REAS  SEC 

B  FOLLOW/R  OUT 


B 

PROC 

PROVl 

(A) 

B 

PROC 

PROVl 

(B) 

B 

PROC 

PROVl 

(C) 

B 

PROC 

PROVl 

(D) 

B 

PROC 

PROVl 

(E) 

B 

PROC 

'  ■'"VI 

(F) 

B 

PROC 

PROVl 

fG) 

739160104040011  H0024080001 
2090900706202024V0005010002 
0080800716001024V0012010003 
0070601714501024V0054 020004 
2171205818100024H0002010005 
2434300574601014V0012 020006 
1454500555201014V0004010007 
1444400554601014V0010010008 
044440033200109  V0014000009 
0434300322001014V0013010010 
1423901332401014V0040040011 
1332501554601014V0090090012 
1373601554601014V002 002 0013 
2141400544601024V0009010014 
2373700351401014V0022020015 
029290033200109  V0014000016 
0282800322001024V0013 010017 
1272401332401024V0040040018 
2313100351401024V0022020019 
230300011090109  V0003000020 
2272501080800024H0003010021 
2 1717007 17001024V0002 010022 
217170063610109  V0003000023 
2141201606000024H0003010024 
2040400706002024V0006010025 
0030300716001024V0012010026 
0020101714501024V0054020027 
217170032320011  V0001010028 
2 2 0200024 14 1002 4V0002 010029 
2191900222001024V0003 010030 
2191900181501024V0004010031 
805  050032 
306060022140111  H0009090033 
320200009070111  H0003030034 
208080006060011  V0001010035 
1110701071601024V0050050036 
202020006060011  V0001010037 
1050101071601024V0050050038 
211110020200011  V0001010039 
2 121200747602 024V0002 010040 
11107017483 01034V0050050041 
2 060600747602 024V0002 01004 2 
10501017483 0103 4 V005005004 3 
2383800282701024V0002010044 
347470009090011  H0001010045 
347470011130111  H0003030046 
347470015150011  H0001010047 
347470018190111  H0002020048 
347470022240111  H0003030049 
335350008080011  H0001010050 
335350012230111  H0012120051 
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B  PROC  PROVl  (H)  323230009110111  H0003030052 
B  PROC  PROVl  (I)  323230013130011  H0001010053 
B  PROC  PROVl  (J)  323230015160111  H0002020054 
B  PROC  PROVl  (K)  323230018220111  H0005050055 
B  PROC  PROVl  (L)  323230024240011  H0001010056 
B  PROC  PROVl  (M)  311110018180011  H0001010057 
B  PROC  PROV2  (A)  346460009090011  H0001010058 
B  PROC  PROV2  (B)  346460011130111  H0003030059 
B  PROC  PROV2  (C)  346460015150011  H0001010060 
B  PROC  PROV2  (D)  346460018190111  H0002020061 
B  PROC  PROV2  (E)  346460022240111  H0003030062 
B  PROC  PROV2  (F)  334340008080011  H0001010063 
B  PROC  PROV2  (G)  334340012230111  H0012120064 
B  PROC  PROV2  (H)  322220009110111  H0003030065 
B  PROC  PROV2  (I)  322220013130011  H0001010066 
B  PROC  PROV2  (J)  322220015160111  H0002020067 
B  PROC  PROV2  (K)  322220018220111  H0005050068 
B  PROC  PROV2  (L)  322220024240011  H0001010069 
B  PROC  PROV2  (M)  310100018180011  H0001010070 
B  DXl  COLl  (A)  247470032390109  V0008000071 
B  DXl  COLl  (B)  247470042500109  V0009000072 
B  DXl  COLl  (C)  247470053550109  V0003000073 
B  DXl  COLl  (D)  247470057620109  V0006000074 
B  DXl  COLl  (E)  247470064640009  V0001000075 
B  DXl  COLl  (F)  247470066690109  V0004000076 
B  DXl  COLl  (G)  247470071730109  V0003000077 
B  DXl  COLl  (H)  247470075750009  V0001000078 
B  DXl  COLl  (I)  2474700778101024V0005020079 
B  DXl  COL2  (A)  235350030310109  V0002000080 
B  DXl  COL2  (B)  235350033360109  V0004000081 
B  DXl  COL2  (C)  235350038420109  V0005000082 
B  DXl  COL2  (D)  235350045470109  V0003000083 
B  DXl  COL2  (E)  235350049490009  V0001000084 
B  DXl  COL2  (F)  235350051530109  V0003000085 
B  DXl  COL2  (G)  235350055560109  V0002000086 
B  DXl  COL2  (H)  235350059600109  V0002000087 
B  DXl  COL2  (I)  2353500626401024V0003020088 
B  DXl  COL3  (A)  223230031310009  V0001000089 
B  DXl  COL3  (B)  223230033360109  V0004000090 
B  DXl  COL3  (C)  223230039410109  V0003000091 
B  DXl  COL3  (D)  223230044590109  V0016000092 
B  DXl  COL3  (E)  2232300616100024V0001020093 
B  DX2  (A)  346460032390111  H0008080094 
B  DX2  (B)  346460042500111  H0009090095 
B  DX2  (C)  346460053550111  H0003030096 
B  DX2  (D)  346460057620111  H0006060097 
B  DX2  (E)  346460064640011  H0001010098 
B  DX2  (F)  346460066690111  H0004040099 
B  DX2  (G)  346460071730111  H0003030100 
B  DX2  (H)  346460075750011  HOOOIOIOIOI 
B  DX2  (I)  346460077810111  H0005050102 
B  DX2  (J)  334340030310111  H0002020103 
B  DX2  (K)  334340033360111  H0004040104 
B  DX2  (L)  334340038420111  H0005050105 
B  DX2  (M)  334340045470111  H0003030106 


CQOOPQCQOQfOfQnCQ 


DX2 

(N) 

DX2 

(O) 

DX2 

(P) 

DX2 

(Q) 

DX2 

(R) 

DX2 

(S) 

DX2 

(T) 

DX2 

(U) 

DX2 

(V) 

//EOF0504 


334340049490011  H0001010107 
334340051530111  H0003030108 
334340055560111  H0002020109 
334340059600111  H0002020110 
334340062640111  H0003030111 
322220031310011  H0001010112 
322220033360111  H0004040113 
322220039410111  H0003030114 
322220044590111  H0016160115 


I 


I 


770  RHEUMATOLOGY 

I  H03830247NY0051R 

H010226 


B 

LITHO 

B 

UCA 

PFX 

B 

UCA  CODE  1 

B 

UCA  CODE  2 

B 

OTHER  UCA 

B 

DATE 

(MO) 

B 

DATE 

(DY)1 

B 

DATE 

(DY)2 

B 

PROVl 

PFXl 

B 

PROVl 

PFX2 

B 

PROVl 

CODE 

B 

SSN 

B 

FMP 

B 

VISIT 

COUNT 

B 

PROVl 

TIME 

B 

PROV2 

PFXl 

B 

PROV2 

PFX2 

B 

PROV2 

CODE 

B 

PROV2 

TIME 

BREASON  FOR  #2  (1) 
BREASON  FOR  #2  (2) 
B  IF  NOT  SCHED 

BIF  NOT  CLINIC  (1) 
BIF  NOT  CLINIC  (2) 
B  REF  CODE  PFX 

B  REF  CODE  1 
B  REF  CODE  2 

B  JOB  RELATED 
B  MIL  ONLY  DUTY 

B  MIL  ONLY  QTRS 

B  MIL  ONLY  PROF 

F  FILLER 

B  SPEC  PRE  CLIN 

B  NOT  AVAILABLE 

BPROV2  ADDLl  (YES) 
B  ADDL  PROCl 
BPROV2  ADDL2  (YES) 
B  ADDL  PROC2 
B  ADMITTED 
BUNL  REAS  PRIM  PFX 
B  UNL  REAS  PRIM 
B  UNL  REAS  SEC  PFX 
B  UNL  REAS  SEC 
B  FOLLOW/R  OUT 

B  PROC  PROVl  (A) 

B  PROC  PROVl  (B) 

B  PROC  PROV2  (A) 

B  PROC  PROV2  (B) 

B  OTHER  CODES 
B  DXl  COLl  (A) 

B  DXl  COLl  (B) 


SCAN770.FIL 

MATOLOGY  * 

* 

739160104040011  H0024080001 
2090900706202024V0005010002 
0080800716001024V0012010003 
0070601714501024V0054020004 
2171700818100024V0001010005 
24 34 300574 601014V0012020006 
1454500555201014V0004010007 
1444400554601014V0010010008 
044440033200109  V0014000009 
0434300322001014V0013010010 
1423901332401014V0040040011 
1332501554601014V0090090012 
1373601554601014V0020020013 
2141400544601024V0009010014 
23737003514 01014V0022 02 0015 
029290033200109  V0014000016 
0282800322001024V0013010017 
1272401332401024V0040040018 
2313100351401024V0022020019 
230300011090109  V0003000020 
2272501080800024H0003010021 
2171700717001024V0002010022 
217170063610109  V0003000023 
2141201606000024H0003010024 
2040400706002024V0006010025 
0030300716001024V0012010026 
0020101714501024V0054020027 
217170032320011  V0001010028 
2202000241410024V0002010029 
2191900222001024V0003010030 
2191900181501024V0004010031 
805  050032 

306060022140111  H0009090033 
320200009070111  H0003030034 
208080006060011  V0001010035 
1110701071601024V0050050036 
202020006060011  V0001010037 
1050101071601024V0050050038 
235350021210011  V0001010039 
2121200747602024V0002010040 
1 1 107017483 01034V0050050041 
2060600747602024V0002010042 
1050101748301034V0050050043 
2 383800272 601024V0002010044 
347470008150111  H0008080045 
347470017170011  H0001010046 
346460008150111  H0008080047 
346460017170011  H0001010048 
334340009190111  H0011110049 
247470031370109  V0007000050 
247470040440109  V0005000051 


B 

DXl 

COLl 

(C) 

247470048500109 

V0003000052 

B 

DXl 

COLl 

(D) 

247470053530009 

V0001000053 

B 

DXl 

COLl 

(E) 

247470055580109 

V0004000054 

B 

DXl 

COLl 

(F) 

247470060630109 

V0004000055 

B 

DXl 

COLl 

(G) 

247470065710109 

V0007000056 

B 

DXl 

COLl 

(H) 

2474700747801024V0005020057 

B 

DXl 

COL2 

(A) 

235350029300109 

V0002000058 

B 

DXl 

COL2 

(B) 

235350033330009 

V0001000059 

B 

DXl 

COL2 

(C) 

235350035390109 

V0005000060 

B 

DXl 

COL2 

(D) 

235350042430109 

V0002000061 

B 

DXl 

COL2 

(E) 

235350046530109 

V0008000062 

B 

DXl 

COL2 

(F) 

235350056620109 

V0007000053 

B 

DXl 

COL2 

(G) 

235350065670109 

V0003000064 

B 

DXl 

COL2 

(H) 

235350070710109 

V0002000065 

B 

DXl 

COL2 

(I) 

2353500737401024V0002020066 

B 

DXl 

COL3 

(A) 

223230029300109 

V0002000067 

B 

DXl 

COL3 

(B) 

223230033370109 

V0005000068 

B 

DXl 

COL3 

(C) 

223230041440109 

V0004000069 

B 

DXl 

COL3 

(D) 

223230047470009 

V0001000070 

B 

DXl 

COL3 

(E) 

223230049490009 

V0001000071 

B 

DXl 

COL3 

(F) 

223230053540109 

V0002000072 

B 

DXl 

COL3 

(G) 

223230057610109 

V0005000073 

B 

DXl 

COL3 

(H) 

2232300647701024V0014 020074 

B 

DXl 

COL4 

(A) 

211110029300109 

V0002000075 

B 

DXl 

COL4 

(B) 

211110032330109 

V0002000076 

B 

DXl 

COL4 

(C) 

211110035360109 

V0002000077 

B 

DXl 

COL4 

(D) 

211110038390109 

V0002000078 

B 

DXl 

COL4 

(E) 

211110041430109 

V0003000079 

B 

DXl 

COL4 

(F) 

211110045460109 

V0002000080 

B 

DXl 

COL4 

(G) 

211110049490009 

V0001000081 

B 

DXl 

COL4 

(H) 

211110051520109 

V0002000082 

B 

DXl 

COL4 

(I) 

211110054640109 

V0011000083 

B 

DXl 

COL4 

(J) 

2111100666600024V0001020084 

B 

DX2 

(A) 

346460031370111 

H0007070085 

B 

DX2 

(B) 

346460040440111 

H0005050086 

B 

DX2 

(C) 

346460048500111 

H0003030087 

B 

DX2 

(D) 

346460053530011 

H0001010088 

B 

DX2 

(E) 

346460055580111 

H0004040089 

B 

DX2 

(F) 

346460060630111 

H0004040090 

B 

DX2 

(G) 

346460065710111 

H0007070091 

B 

DX2 

(H) 

346460074780111 

H0005050092 

B 

DX2 

(I) 

334340029300111 

H0002020093 

B 

DX2 

(J) 

334340033330011 

H0001010094 

B 

DX2 

(K) 

334340035390111 

H0005050095 

B 

DX2 

(L) 

334340042430111 

H0002020096 

B 

DX2 

(M) 

334340046530111 

H0008080097 

B 

DX2 

(N) 

334340056620111 

H0007070098 

B 

DX2 

(0) 

334340065670111 

H0003030099 

B 

DX2 

(P) 

334340070710111 

H0002020100 

B 

DX2 

(Q) 

334340073740111 

H0002020101 

B 

DX2 

(R) 

322220029300111 

H0002020102 

B 

DX2 

(S) 

322220033370111 

H0005050103 

B 

DX2 

(T) 

322220041440111 

H0004040104 

B 

Dx:2 

(U) 

322220047470011 

H0001010105 

B 

DX2 

fV) 

322220049490011 

H0001010106 
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DX2  (W)  322220053540111  H0002020107 

DX2  (X)  322220057610111  H0005050108 

DX2  (Y)  322220064770111  H0014140109 

DX2  (Z)  310100029300111  H0002020110 

DX2  (AA)  310100032330111  H0002020111 

DX2  (BB)  310100035360111  H0002020112 

DX2  (CC)  310100038390111  H0002020113 

DX2  (DD)  310100041430111  H0003030114 

DX2  (EE)  310100045460111  H0002020115 

DX2  (FF)  310100049490011  H0001010116 

DX2  (GG)  310100051520111  H0002020117 

DX2  (HH)  310100054640111  H0011110118 

//EOF0503 


780  SOCIAL  WORK 


SCAN780.FIL 


H03830247NY0051SOCIAL  WORK  * 
H020445  * 
B  LITHO  739160104040011  H0024080001 
B  UCA  PFX  2090900706202024V0005010002 
B  UCA  CODE  1  0080800716001024V0012010003 
B  UCA  CODE  2  0070601714501024V0054020004 
B  OTHER  UCA  2171205818100024H0002010005 
B  DATE  (MO)  2434300574601014V0012020006 
B  DATE  (DY)1  1454500555201014V0004010007 
B  DATE  (DY)2  1444400554601014V0010010008 
B  PROVl  PFXl  044440033200109  V0014000009 
B  PROVl  PFX2  0434300322001014V0013010010 
B  PROVl  CODE  1423901332401014V0040040011 
B  SSN  1332501554601014V0090090012 
B  FMP  1373601554601014V0020020013 
B  VISIT  COUNT  2141400544601024V0009010014 
B  PROVl  TIME  2373700351401014V0022020015 
B  PROV2  PFXl  029290033200109  V0014000016 
B  PROV2  PFX2  0282800322001024V0013010017 
B  PROV2  CODE  1272401332401024V0040040018 
B  PROV2  TIME  2313100351401024V0022020019 
BREASON  FOR  #2  (1)  230300011090109  V0003000020 
BREASON  FOR  #2  (2)  227250108080009  H0003000021 
BREAS  FOR  2 (COTHER) 2303000121200024V0001010022 
B  IF  NOT  SCHED  2171700717001024V0002010023 
BIF  NOT  CLINIC  (1)  217170063610109  V0003000024 
BIF  NOT  CLINIC  (2)  2141201606000024H0003010025 
B  REF  CODE  PFX  2040400706002024V0006010026 
B  REF  CODE  1  0030300716001024V0012010027 
B  REF  CODE  2  0020101714501024V0054020028 
B  JOB  RELATED  217170032320011  V0001010029 
B  MIL  ONLY  DUTY  2202000241410024V0002010030 
B  MIL  ONLY  QTRS  2191900222001024V0003010031 
B  MIL  ONLY  PROF  2191900181501024V0004010032 
F  FILLER  805  050033 
B  SPEC  PRE  CLIN  306060022140111  H0009090034 
B  NOT  AVAILABLE  320200009070111  H0003030035 
BPROV2  ADDLl  (YES)  208080006060011  V0001010036 
B  ADDL  PROCl  1110701071601024V0050050037 
BPROV2  ADDL2  (YES)  202020006060011  V0001010038 
B  ADDL  PROC2  1050101071601024V0050050039 
F  ADMITTED  801  010040 
BUNL  REAS  PRIM  PFX  2121200747602024V0002010041 
B  UNL  REAS  PRIM  1110701748301034V0050050042 
B  UNL  REAS  SEC  PFX  2060600747602024V0002010043 
B  UNL  REAS  SEC  1050101748301034V0050050044 
B  FOLLOW/R  OUT  2383800323101024V0002010045 
B  PROC  PROVl  (A)  347470008240111  H0017170046 
B  PROC  PROVl  (B)  335350008080011  H0001010047 
B  PROC  PROVl  (C)  335350010200111  H0011110048 
B  PROC  PROVl  (D)  335350022220011  H0001010049 
B  PROC  PROVl  (E)  335350024240011  H0001010050 
B  PROC  PROVl  (F)  335350026280111  H0003030051 
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B  PROC  PROV2  (A)  346460008240111  H0017170052 
B  PROC  PROV2  (B)  334340008080011  H0001010053 
B  PROC  PROV2  (C)  334340010200111  H0011110054 
B  PROC  PROV2  (D)  334340022220011  H0001010055 
B  PROC  PROV2  (E)  334340024240011  H0001010056 
B  PROC  PROV2  (F)  334340026280111  H0003030057 
B  OTHER  CODES  311110018180011  H0001010058 
B  DXl  COLl  (A)  247470036380109  V0003000059 
B  DXl  COLl  (B)  247470040440109  V0005000060 
B  DXl  COLl  (C)  247470046470109  V0002000061 
B  DXl  COLl  (D)  247470049500109  V0002000062 
B  DXl  COLl  (E)  247470052530109  V0002000063 
B  DXl  COLl  (F)  247470055570109  V0003000064 
B  DXl  COLl  (G)  247470059600109  V0002000065 
B  DXl  COLl  (H)  247470063650109  V0003000066 
B  DXl  COLl  (I)  247470067670009  V0001000067 
B  DXl  COLl  (J)  247470069700109  V0002000068 
B  DXl  COLl  (K)  247470072750109  V0004000069 
B  DXl  COLl  (L)  2474700777700024V0001020070 
B  DXl  COL2  (A)  235350034350109  V0002000071 
B  DXl  COL2  (B)  235350037380109  V0002000072 
B  DXl  COL2  (C)  235350040490109  V0010000073 
B  DXl  COL2  (D)  235350052590109  V0008000074 
B  DXl  COL2  (E)  235350062660109  V0005000075 
B  DXl  COL2  (F)  235350069690009  V0001000076 
B  DXl  COL2  (G)  235350071710009  V0001000077 
B  DXl  COL2  (H)  235350073760109  V0004000078 
B  DXl  COL2  (I)  2353500787901024V0002020079 
B  DXl  COL3  (A)  223230034350109  V0002000080 
B  DXl  COL3  (B)  223230037370009  V0001000081 
B  DXl  COL3  (C)  223230039390009  V0001000082 
B  DXl  COL3  (D)  223230042420009  V0001000083 
B  DXl  COL3  (E)  223230044460109  V0003000084 
B  DXl  COL3  (F)  223230049500109  V0002000085 
B  DXl  COL3  (G)  223230052520009  V0001000086 
B  DXl  COL3  (H)  223230054550109  V0002000087 
B  DXl  COL3  (I)  223230058640109  V0007000088 
B  DXl  COL3  (J)  223230066660009  V0001000089 
B  DXl  COL3  (K)  223230069700109  V0002000090 
B  DXl  COL3  (L)  223230072760109  V0005000091 
B  DXl  COL3  (M)  2232300787800024V0001020092 
B  DXl  COL4  (A)  211110034350109  V0002000093 
B  DXl  COL4  (B)  211110037370009  V0001000094 
B  DXl  COL4  (C)  211110039390009  V0001000095 
B  DXl  COL4  (D)  211110042420009  V0001000096 
B  DXl  COL4  (E)  211110044450109  V0002000097 
B  DXl  COL4  (F)  211110047480109  V0002000098 
B  DXl  COL4  (G)  211110050500009  V0001000099 
B  DXl  COL4  (H)  211110053550109  V0003000100 
B  DXl  COL4  (I)  211110058600109  V0003000101 
B  DXl  COL4  (J)  211110062640109  V0003000102 
B  DXl  COL4  (K)  2111100666801024V0003020103 
B  DX2  (A)  346460036380111  H0003030104 
B  DX2  (B)  346460040440111  H0005050105 
B  DX2  (C)  346460046470111  H0002020106 


-86- 
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DX2 

(D) 

346460049500111 

H0002020107 

DX2 

(E) 

346460052530111 

H0002020108 

DX2 

(F) 

346460055570111 

H0003030109 

DX2 

(G) 

346460059600111 

H0002020110 

DX2 

(H) 

346460063650111 

H0003030111 

DX2 

(I) 

346460067670011 

H0001010112 

DX2 

(J) 

346460069700111 

H0002020113 

DX2 

(K) 

346460072750111 

H0004040114 

DX2 

(L) 

346460077770011 

H0001010115 

DX2 

(M) 

334340034350111 

H0002020116 

DX2 

(N) 

334340037380111 

H0002020117 

DX2 

(0) 

334340040490111 

H0010100118 

DX2 

(P) 

334340052590111 

H0008080119 

DX2 

(Q) 

334340062660111 

H0005050120 

DX2 

(R) 

334340069690011 

H0001010121 

DX2 

(S) 

334340071710011 

H0001010122 

DX2 

(T) 

334340073760111 

H0004040123 

DX2 

(U) 

334340078790111 

H0002020124 

DX2 

(V) 

322220034350111 

H0002020125 

DX2 

(W) 

322220037370011 

H0001010126 

DX2 

(X) 

322220039390011 

H0001010127 

DX2 

(Y) 

322220042420011 

H0001010128 

DX2 

(Z) 

322220044460111 

H0003030129 

DX2 

(AA) 

322220049500111 

H0002020130 

DX2 

(BB) 

322220052520011 

H0001010131 

DX2 

(CC) 

322220054550111 

H0002020132 

DX2 

(DD) 

322220058640111 

H0007070133 

DX2 

(EE) 

322220066660011 

H0001010134 

DX2 

(FF) 

322220069700111 

H0002020135 

DX2 

(GG) 

322220072760111 

H0005050136 

DX2 

(HH) 

322220078780011 

H0001010137 

DX2 

(II) 

310100034350111 

H0002020138 

DX2 

(JJ) 

310100037370011 

H0001010139 

DX2 

(KK) 

310100039390011 

H0001010140 

DX2 

(LL) 

310100042420011 

H0001010141 

DX2 

(MM) 

310100044450111 

H0002020142 

DX2 

(NN) 

310100047480111 

H0002020143 

DX2 

(00) 

310100050500011 

H0001010144 

DX2 

(PP) 

310100053550111 

H0003030145 

DX2 

(QQ) 

310100C58600111 

H0003030146 

DX2 

(RR) 

310100062640111 

H0003030147 

DX2 

(SS) 

310100066670111 

H000202014B 

SPEC  PROG  (1) 

307070035320111 

H0004040149 

SPEC  PROG  (2) 

304020131310011 

V0003030150 
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790  UROLOGY 


SCAN790.FIL 


H03830247NY0051UROLOGY  * 
H010231  * 
B  LITHO  739160104040011  H0024080001 
B  UCA  PFX  2090900706202024V0005010002 
B  UCA  CODE  1  0080800716001024V0012010003 
B  UCA  CODE  2  0070601714501024V0054020004 
F  OTHER  UCA  801  010005 
B  DATE  (MO)  2434300574601014V0012020006 
B  DATE  (DY)1  1454500555201014V0004010007 
B  DATE  (DY)2  1444400554601014V0010010008 
B  PROVl  PFXl  044440033200109  V0014000009 
B  PROVl  PFX2  0434300322001014V0013010010 
B  PROVl  CODE  1423901332401014V0040040011 
B  SSN  1332501554601014V0090090012 
B  FMP  1373601554601014V0020020013 
B  VISIT  COUNT  2141400544601024V0009010014 
B  PROVl  TIME  2373700351401014V0022020015 
B  PROV2  PFXl  029290033200109  V0014000016 
B  PROV2  PFX2  0282800322001024V0013010017 
B  PROV2  CODE  1272401332401024V0040040018 
B  PROV2  TIME  2313100351401024V0022020019 
BREASON  FOR  #2  (1)  230300011090109  V0003000020 
BREASON  FOR  #2  (2)  2272501080800024H000301002 1 
B  IF  NOT  SCHED  2171700717001024V0002010022 
BIF  NOT  CLINIC  (1)  217170063610109  V0003000023 
BIF  NOT  CLINIC  (2)  2141201606000024H0003010024 
B  REF  CODE  PFX  2040400706002024V0006010025 
B  REF  CODE  1  0030300716001024V0012010026 
B  REF  CODE  2  0020101714501024V0054020027 
B  JOB  RELATED  217170032320011  V0001010028 
B  MIL  ONLY  DUTY  220200024 14 10024V0002010029 
B  MIL  ONLY  QTRS  2191900222001024V0003010030 
B  MIL  ONLY  PROF  2191900181501024V0004010031 
F  FILLER  805  050032 
B  SPEC  PRE  CLIN  306060022140111  H0009090033 
B  NOT  AVAILABLE  320200009070111  H0003030034 
BPROV2  ADDLl  (YES)  208080006060011  V0001010035 
B  ADDL  PROCl  1110701071601024V0050050036 
BPROV2  ADDL2  (YES)  202020006060011  V0001010037 
B  ADDL  PROC2  1050101071601024V0050050038 
B  ADMITTED  211110019190011  V0001010039 
BUNL  REAS  PRIM  PFX  2121200747602024V0002010040 
B  UNL  REAS  PRIM  1110701748301034V0050050041 
B  UNL  REAS  SEC  PFX  2060600747602024V0002010042 
B  UNL  REAS  SEC  1050101748301034V0050050043 
B  FOLLOW/R  OUT  2383800393801024V0002010044 
B  PROC  PROVl  (A)  347470008090111  H0002020045 
B  PROC  PROVl  (B)  347470011200111  H0010100046 
B  PROC  PROVl  (C)  347470023230011  H0001010047 
B  PROC  PROVl  (D)  347470025300111  H0006060048 
B  PROC  PROVl  (E)  347470032320011  H0001010049 
B  PROC  PROVl  (F)  347470034350111  H0002020050 
B  PROC  PROVl  (G)  335350008120111  H0005050051 
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B  PROC  PROVl  (H)  335350014150111  H0002020052 
B  PROC  PROVl  (I)  335350017290111  H0013130053 
B  PROC  PROVl  (J)  323230009100111  H0002020054 
B  PROC  PROVl  (K)  323230012150111  H0004040055 
B  PROC  PROVl  (L)  323230017220111  H0006060056 
B  PROC  PROVl  (M)  323230024250111  H0002020057 
B  PROC  PROV2  (A)  346460008090111  H0002020058 
B  PROC  PROV2  (B)  346460011200111  H0010100059 
B  PROC  PROV2  (C)  346460023230011  H0001010060 
B  PROC  PROV2  (D)  346460025300111  H0006060061 
B  PROC  PROV2  (E)  346460032320011  H0001010062 
B  PROC  PROV2  (F)  346460034350111  H0002020063 
B  PROC  PROV2  (G)  334340008120111  H0005050064 
B  PROC  PROV2  (H)  334340014150111  H0002020065 
B  PROC  PROV2  (I)  334340017290111  H0013130066 
B  PROC  PRCV2  (J)  322220009100111  H0002020067 
B  PROC  PROV2  (K)  322220012150111  H0004040068 
B  PROC  PROV2  (L)  322220017220111  H0006060069 
B  PROC  PROV2  (M)  322220024250111  H0002020070 
BDXl  COLl  (A)  247470043490109  V0007000071 
BDXl  COLl  (B)  247470051520109  V0002000072 
BDXl  COLl  (C)  247470054570109  V0004000073 
BDXl  COLl  (D)  2474700606501024V0006020074 
BDXl  COL2  (A)  235350041420109  V0002000075 
BDXl  COL2  (B)  235350044490109  V0006000076 
BDXl  COL2  (C)  235350052600109  V0009000077 
BDXl  COL2  (D)  235350062630109  V0002000078 
BDXl  COL2  (E)  2353500666901024V0004020079 
BDXl  COL3  (A)  223230041530109  V0013000080 
BDXl  COL3  (B)  223230055580109  V0004000081 
BDXl  COL3  (C)  223230060610109  V0002000082 
BDXl  COL3  (D)  223230063640109  V0002000083 
BDXl  COL3  (E)  223230066690109  V0004000084 
BDXl  COL3  (F)  223230071750109  V0005000085 
BDXl  COL3  (G)  223230077770009  V0001000086 
BDXl  COL3  (H)  2232300798001024V0002020087 
BDXl  COL4  (A)  211110042510109  V0010000088 
BDXl  COL4  (B)  211110053530009  V0001000089 
BDXl  COL4  (C)  2111100555500024V0001020090 
B  DX2  (A)  346460043490111  H0007070091 
B  DX2  (B)  346460051520111  H0002020092 
B  DX2  (C)  346460054570111  H0004040093 
B  DX2  (D)  346460060650111  H0006060094 
B  DX2  (E)  334340041420111  H0002020095 
B  DX2  (F)  334340044490111  H0006060096 
B  DX2  (G)  334340052600111  H0009090097 
B  DX2  (H)  334340062630111  H0002020098 
B  DX2  (I)  334340066690111  H0004040099 
B  DX2  (J)  322220041530111  H0013130100 
B  DX2  (K)  322220055580111  H0004040101 
B  DX2  (L)  322220060610111  H0002020102 
B  DX2  (M)  322220063640111  H0002020103 
B  DX2  (N)  322220066690111  H0004040104 
B  C/  i  322220071750111  H0005050105 
B  DX2  (P)  322220077770011  H0001010106 
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CQ  CQ  PQ 


DX2  (Q)  322220079800111  H0002020107 

DX2  (R)  310100042510111  H0010100108 

DX2  (S)  310100053530011  H0001010109 
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800  BAS/TMC 


SCAN800.FIL 


H02830247NY0051BAS/TMC  * 

H0546  * 

B  LITHO  739160104040011  H0024080001 

B  DATE  (MO)  2070700716001014V0012020002 

B  DATE  (DY)  1090801696001014V0020020003 

B  SSN  1090101544501014V0090090004 

B  APPT.  STATUS  2121200413901024V0003010005 
B  INJURIES  (A)  206060042380109  V0005000006 

B  INJURIES  (B)  2060600363600024V0001010007 

B  JOB  RELATED  206060029290011  V0001010008 
BMILITARY  DUTY  (A)  209090024141009  V0002000009 
BMILITARY  DUTY  (B)  2090900131300024V0001010010 
BMILITARY  QUARTERS  2080800222001024V0003010011 
B  MILITARY  PROFILE  2080800181501024V0004010012 
BTMC  DISPOSITION  209090025250011  V0001010013 
BPREASSIGNED  CODES  301010024160111  H0009090014 
B  BAS  UCA  0434201785201024V0054020015 

BBAS  PROVl  PFX  (A)  037370077640109  V0014000016 
BBAS  PROVl  PFX  (B)  0363600766401024V0013010017 
B  BAS  PROVl  CODE  1333001776801024V0040040018 

B  BAS  PROVl  TIME  2272700797101024V0009010019 

BBAS  PROV2  PFX  (A)  021210077640109  V0014000020 
BBAS  PROV2  PFX  (B)  0202000766401024V0013010021 
B  BAS  PROV2  CODE  1171401776801024V0040040022 

B  BAS  PROV2  TIME  2242400797101024V0009010023 

V*  BBAS  REAS  FOR  #2  A  228280067650109  V0003000024 

BBAS  REAS  FOR  #2  B  2262401646400024H0003010025 
BBASPROV2  ADDLPROC12242400616100024V0001010026 
B  BAS  ADDL  PROC  1  1282401584901024V0050050027 
BBASPROV2  ADDLPROC22171700616100024V0001010028 
B  BAS  ADDL  PROC  2  1211701584901024V0050050029 
B  BAS  FIELD  243430050500011  V0001010030 

B  TMC  UCA  PFX  2444400403901024V0002010031 
B  TMC  UCA  CODE  (A)  0434300413901024V0003010032 
B  TMC  UCA  CODE  (B)  0424200411501024V0027010033 
BTMC  PROVl  PFX  (A)  037370041280109  V0014000034 
BTMC  PROVl  PFX  (B)  0363600402801024V0013010035 
B  TMC  PROVl  CODE  1333001413201024V0040040036 

B  TMC  PROVl  TIME  2272700433501024V0009010037 

BTMC  PROV2  PFX  (A)  021210041280109  V0014000038 
BTMC  PROV2  PFX  (B)  0202000402801024V0013010039 
B  TMC  PROV2  CODE  1171401413201024V0040040040 

B  TMC  PROV2  TIME  2242400433501024V0009010041 

BTMC  REAS  FOR  #2  A  228280031290109  V0003000042 
BTMC  REAS  FOR  #2  B  2262401282800024H0003010043 
BTMC  PROV2  ADDL  PR0212120023230011  V0001010044 
B  TMC  ADDL  PROC  1161201201101024V0050050045 

B  TMC  ADMITTED  228280007070011  V0001010046 

BTMC  PROC  PROVl  (A) 340400024 150111  H0010100047 
BTMC  PROC  PROVl  (B) 340400011070111  H0005050048 
BTMC  PROC  PROVl  (0)328280024150111  H0010100049 
BTMC  PROC  PROV2  (A) 339390024150111  H0010100050 
BTMC  PROC  PROV2  (B) 339390011070111  H0005050051 
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BTMC  PROC  PROV2  (C) 327270024150111  H0010100052 
B  FOLLOW/R  OUT  2424200050401024V0002010053 
BPRIM  UNL  REAS  PFX  2121200747602024V0002010054 
B  PRIM  UNL  REAS  1110701748301034V0050050055 
B  SEC  UNL  REAS  PFX  2060600747602022V0002010056 
B  SEC  UNL  REAS  1050101748301034V0050050057 
B  DXl  COLl  (A)  247470009120109  V0004000058 
B  DXl  COLl  (B)  247470016220109  V0007000059 
B  DXl  COLl  (C)  247470024250109  V0002000060 
B  DXl  COLl  (D)  247470027310109  V0005000061 
B  DXl  COLl  (E)  247470033340109  V0002000062 
B  DXl  COLl  (F)  247470036410109  V0006000063 
B  DXl  COLl  (G)  247470043460109  V0004000064 
B  DXl  COLl  (H)  2474700495501024V0007020065 
B  DXl  COL2  (A)  235350007140109  V0008000066 
B  DXl  COL2  (B)  235350018220109  V0005000067 
B  DXl  COL2  (C)  235350024260109  V0003000068 
B  DXl  COL2  (D)  2353500294201024V0014020069 
B  DXl  COL3  (A)  223230007250109  V0019000070 
B  DXl  COL3  (B)  223230028340109  V0007000071 
B  DXl  COL3  (C)  223230037490109  V0013000072 
B  DXl  COL3  (D)  2232300525401024V0003020073 
B  DXl  COL4  (A)  211110007110109  V0005000074 
B  DXl  COL4  (B)  211110013180109  V0006000075 
B  DXl  COL4  (C)  211110022220009  V0001000076 
B  DXl  COL4  (D)  211110024240009  V0001000077 
B  DXl  COL4  (E)  211110027280109  V0002000078 
B  DXl  COL4  (F)  211110030350109  V0006000079 
B  DXl  COL4  (G)  211110037390109  V0003000080 
B  DXl  COL4  (H)  211110042470109  V0006000081 
B  DXl  COL4  (I)  211110050510109  V0002000082 
B  DXl  COL4  (J)  211110053580109  V0006000083 
B  DXl  COL4  (K)  2111100606101024V0002020084 
B  DX2  (A)  346460009120111  H0004040085 
B  DX2  (B)  346460016220111  H0007070086 
B  DX2  (C)  346460024250111  H0002020087 
B  DX2  (D)  346460027310111  H0005050088 
B  DX2  (E)  346460033340111  H0002020089 
B  DX2  (F)  346460036410111  H0006060090 
B  DX2  (G)  346460043460111  H0004040091 
B  DX2  (H)  346460049550111  H0007070092 
B  DX2  (I^  334340007140111  H0008080093 
B  DX2  (J)  334340018220111  H0005050094 
B  DX2  (K)  334340024260111  H0003030095 
B  DX2  (L)  334340029420111  H0014140096 
B  DX2  (M)  322220007250111  H0019190097 
B  DX2  (N)  322220028340111  H0007070098 
B  DX2  (O)  322220037490111  H0013130099 
B  DX2  (P)  322220052540111  H0003030100 
B  DX2  (Q)  310100007110111  H0005050101 
B  DX2  (R)  310100013180111  H0006060102 
B  DX2  (S)  310100022220011  H0001010103 
B  DX2  (T)  310100024240011  H0001010104 
B  DX2  (U)  310100027280111  H0002020105 
B  DX2  (V)  310100030350111  H0006060106 


cc  CQ  n  CQ  0 


DX2  (W) 

DX2  (X) 

DX2  (Y) 

DX2  (Z) 

NOT  AVAILABLE 
//EOF0308 


310100037390111  H0003030107 
310100042470111  H0006060108 
310100050510111  H0002020109 
310100053580111  H0006060110 
312120035330111  H0003030111 
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820  EKG 


SCAN820.FIL 


H02830247NY0051EKG  * 
H0541  * 
B  LITHO  739160104040011  H0024080001 
B  OTHER  UCA  1  208080081770209  V0003000002 
B  OTHER  UCA  2  2040400817702024V0003010003 
B  DATE  (MO)  2424200817001014V0012020004 
B  DATE  (DY)  1464402797001014V0020020005 
B  PROVl  PFX  (1)  035350079660109  V0014000006 
B  PROVl  PFX  (2)  0343400786601014V0013010007 
B  PROVl  CODE  1322602786901014V0040040008 
B  SSN  (1)  1422602605101014V0090090009 
B  FMP  (1)  1464402605101014V0020020010 
BREF  CODE  SINGLE  1A232320047370209  V0006000011 
BREF  CODE  SINGLE  1B2282800473702024V0006020012 
BREFCODE  HAND  PFX  12323200322402024V0005010013 
B  REF  CODE  HAND  1  0302602330701024V0081030014 
B  TIME  SPENT  lA  246460014120109  V0003000015 
B  TIME  SPENT  IB  242420014120109  V0003000016 
B  TIME  SPENT  1C  2383800141201024V0003010017 
B  UNLISTED  PROC  1  1463802261701024V0050050018 
B  PROCEDURES  1  346460048310111  H0018180019 
B  SP  PRE  CLIN  1  345370107070011  V0009090020 
B  SSN  2  1180202605101024V0090090021 
B  FMP  2  1222002605101024V0020020022 
BREF  CODE  SINGLE  2A208080047370209  V0006000023 
BREF  CODE  SINGLE  2B2040400473702024V0006020024 
BREFCODE  HAND  PFX  22080800322402024V0005010025 
B  REF  CODE  HAND  2  0060202330701024V0081030026 
B  TIME  2A  222220014120109  V0003000027 
B  TIME  2B  218180014120109  V0003000028 
B  TIME  2C  2141400141201024V0003010029 
B  UNLISTED  PROC  2  1221402261701024V0050050030 
B  PROCEDURES  2  322220048310111  H0018180031 
B  SP  PRE  CLIN  2  321130107070011  V0009090032 
B  SSN  3  1432702152401024V0090090033 
B  FMP  3  1474502152401024V0020020034 
BREFCODE  SINGLE  3A  233330028380209  V0006000035 
BREFCODE  SINGLE  3B  2292900283802024V0006020036 
BREFCODE  HAND  PFX  32333300435102024V0005010037 
B  REF  CODE  HAND  3  0312702426801024V0081030038 
B  TIME  SPENT  3A  247470061630109  V0003000039 
B  TIME  SPENT  3B  243430061630109  V0003000040 
B  TIME  SPENT  3C  2393900616301024V0003010041 
B  UNLISTED  PROC  3  1473902495801024V0050050042 
B  PROCEDURES  3  347470027440111  H0018180043 
B  SP  PRE  CLIN  3  346380168680011  V0009090044 
B  SSN  4  1190302152401024V0090090045 
B  FMP  4  1232102152401024V0020020046 
BREF  CODE  SINGLE  4A209090028380209  V0006000047 
BREF  CODE  SINGLE  4B2050500283802024V0006020048 
BREFCODE  HAND  PFX  42090900435102024V0005010049 
B  REF  CODE  HAND  4  0070302426801024V0081030050 
B  TIME  SPENT  4A  223230061630109  V0003000051 


B  TIME  SPENT  4B  219190061630109  V0003000052 
B  TIME  SPENT  4C  2151500616301024V0003010053 
B  UNLISTED  PROC  4  1231502495801024V0050050054 
B  PROCEDURES  4  323230027440111  H0018180055 
B  SP  PRE  CLIN  4  322140168680011  V0009090056 
//EOF0218 
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830  EMERGENCY  ROOM 


SCAN830.FIL 


H02830247NY0051EMERGENCY  ROOM  * 
H0540  * 
B  LITHO  739160104040011  H0024080001 
F  CLINIC  PFX  801  010002 
F  CLINIC  CODE  803  030003 
F  OTHER  UCA  801  010004 


B  DATE  (MO)  2191900705901024V0012020005 
B  DATE  (DY)1  1212100686501014V0004010006 
B  DATE  (DY)2  1202000685901014V0010010007 
B  PROVl  PFXl  045450077640109  V0014000008 
B  PROVl  PFX2  0444400766401014V0013010009 
B  PROVl  CODE  1434001776801014V0040040010 
B  SSN  1090101635401014V0090090011 
B  FMP  1131201635401014V0020020012 
F  VISIT  COUNT  801  010013 
B  PROVl  TIME  2383800795801014V0022020014 
B  PROV2  PFXl  030300077640109  V0014000015 
B  PROV2  PFX2  0292900766401024V0013010016 
B  PROV2  CODE  1282501776801024V0040040017 
B  PROV2  TIME  2323200795801024V0022020018 
BREASON  FOR  #2  (A)  231310055530109  V0003000019 
BREASON  FOR  #2  (B)  2282601525200024H0003010020 
B  IF  NOT  EMERGENCY  205050046460011  V0001010021 
B  SEEN  IN  HOSPITAL  217170046460011  V0001010022 
F  REF  CODE  PFX  801  010023 
F  REF  CODE  803  030024 
B  JOB  RELATED  229290039390011  V0001010025 
B  MIL  ONLY  DUTY  2444400483810024V0002010026 
B  MIL  ONLY  QTRS  2434300464401024V0003010027 
B  MIL  ONLY  PROF  2434300423901024V0004010028 
F  NOT  AVAIL  801  010029 
B  SP  PRE  CLIN  309010138380011  V0009090030 
F  SPEC  PROG  807  070031 
B  PROV2  ADDLl  208080016160011  V0001010032 
B  ADDL  PROCl  1110701150601024V0050050033 
B  PROV2  ADDL2  202020016160011  V0001010034 
B  ADDL  PROC2  1050101150601024V0050050035 
B  ADMITTED  209090029290011  V0001010036 
BUNL  REAS  PRIM  PFX  2121200747602024V0002010037 
B  UNL  REAS  PRIM  1110701748301034V0050050038 
B  UNL  REAS  SEC  PFX  2060600747602024V0002010039 
B  UNL  REAS  SEC  1050101748301034V0050050040 
B  FOLLOW/R  OUT  2464600050401024V0002010041 


B 

PROC 

PROVl 

(A) 

345450030080111 

H0023230042 

B 

PROC 

PROVl 

(B) 

333330029230111 

H0007070043 

B 

PROC 

PROVl 

(C) 

333330021060111 

H0016160044 

B 

PROC 

PROVl 

(D) 

321210030060111 

H0025250045 

B 

PROC 

PROV2 

(A) 

344440030080111 

H0023230046 

B 

PROC 

PROV2 

(B) 

332320029230111 

H0007070047 

B 

PROC 

PROV2 

(C) 

332320021060111 

H0016160048 

B 

PROC 

PROV2 

(D) 

320200030060111 

H0025250049 

B 

DXl 

COLl 

(A) 

247470009130109 

V0005000050 

B 

DXl 

COLl 

(B) 

247470017240109 

V0008000051 
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B 

DXl 

COLl 

(C) 

247470026320109 

V0007000052 

B 

DXl 

COLl 

(D) 

247470034390109 

V0006000053 

B 

DXl 

COLl 

(E) 

247470041410009 

V0001000054 

B 

DXl 

COLl 

(F) 

247470043460109 

V0004000055 

B 

DXl 

COLl 

(G) 

247470049570109 

V0009000056 

B 

DXl 

COLl 

(H) 

2474700607401024V0015020057 

B 

DXl 

COL2 

(A) 

235350008140109 

V0007000058 

B 

DXl 

COL2 

(B) 

235350016210109 

V0006000059 

B 

DXl 

COL2 

(C) 

235350024320109 

V0009000060 

B 

DXl 

COL2 

(D) 

235350035390109 

V0005000061 

B 

DXl 

COL2 

(E) 

235350042550109 

V0014000062 

B 

DXl 

COL2 

(F) 

235350058690109 

V0012000063 

B 

DXl 

COL2 

(G) 

2353500728101024V0010020064 

B 

DXl 

COL3 

(A) 

223230007080109 

V0002000065 

B 

DXl 

COL3 

(B) 

223230012140109 

V0003000066 

B 

DXl 

COL3 

(C) 

223230016180109 

V0003000067 

B 

DXl 

COL3 

(D) 

223230021370109 

V0017000068 

B 

DXl 

COL3 

(E) 

223230039400109 

V0002000069 

B 

DXl 

COL3 

(F) 

223230042470109 

V0006000070 

B 

DXl 

COL3 

(G) 

223230049520109 

V0004000071 

B 

DXl 

COL3 

(H) 

223230055580109 

V0004000072 

B 

DXl 

COL3 

(I) 

223230061660109 

V0006000073 

B 

DXl 

COL3 

(J) 

2232300687001024V0003020074 

B 

DXl 

COL4 

(A) 

211110021240109 

V0004000075 

B 

DXl 

COL4 

(B) 

211110026260009 

V0001000076 

B 

DXl 

COL4 

(C) 

211110028280009 

V0001000077 

B 

DXl 

COL4 

(D) 

211110030300009 

V0001000078 

B 

DXl 

COL4 

(E) 

211110032360109 

V0005000079 

B 

DXl 

COL4 

(F) 

211110038380009 

V0001000080 

B 

DXl 

COL4 

(G) 

211110040450109 

V0006000081 

B 

DXl 

COL4 

(H) 

211110047490109 

V0003000082 

B 

DXl 

COL4 

(I) 

211110052540109 

V0003000083 

B 

DXl 

COL4 

(J) 

2111100565600024V0001020084 

B 

DX2 

(A) 

346460009130111 

H0005050085 

B 

DX2 

(B) 

346460017240111 

H0008080086 

B 

DX2 

(C) 

346460026320111 

H0007070087 

B 

DX2 

(D) 

346460034390111 

H0006060088 

B 

DX2 

(E) 

346460041410011 

H0001010089 

B 

DX2 

(F) 

346460043460111 

H0004040090 

B 

DX2 

(G) 

346460049570111 

H0009090091 

B 

DX2 

(H) 

346460060740111 

H0015150092 

B 

DX2 

(I) 

334340008140111 

H0007070093 

B 

DX2 

(J) 

334340016210111 

H0006060094 

B 

DX2 

(K) 

334340024320111 

H0009090095 

B 

DX2 

(L) 

334340035390111 

H0005050096 

B 

DX2 

(M) 

334340042550111 

H0014140097 

B 

DX2 

(N) 

334340058690111 

H0012120098 

B 

DX2 

(0) 

334340072810111 

H0010100099 

B 

DX2 

(P) 

322220007080111 

H0002020100 

B 

DX2 

(Q) 

322220012140111 

H0003030101 

B 

DX2 

(R) 

322220016180111 

H0003030102 

B 

DX2 

(S) 

322220021370111 

H0017170103 

B 

DX2 

(T) 

322220039400111 

H0002020104 

B 

DX2 

(U) 

322220042470111 

H0006060105 

3 

DX2 

(V) 

322220049520111 

H0004040106 

i 


i 


j 


i 
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mmcapaamcQcDcaama) 


DX2  (W) 
DX2  (X) 
DX2  (Y) 
DX2  (Z) 
DX2  (AA) 
DX2  (BB) 
DX2  (CC) 
DX2  (DD) 
DX2  (EE) 
DX2  (FF) 
DX2  (GG) 
DX2  (HH) 
//EOF0440 


322220055580111 

322220061660111 

322220068700111 

310100021240111 

310100026260011 

310100028280011 

310100030300011 

310100032360111 

310100038380011 

310100040450111 

310100047490111 

310100052540111 
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H0004040107 

H0006060108 

H0003030109 

H0004040110 

HOOOlOlOlll 

H0001010112 

H0001010113 

H0005050114 

H0001010115 

H0006060116 

H0003030117 

H0003030118 


840  GROUP  FORM  I 


SCAN840.FIL 


H02830247NY0051GROUP  FORM  I  * 

H0146  * 

B  LITHO  746210104040011  H0026080001 

B  UCA  PFX  2080800787002014V0005010002 

B  UCA  CODE  0060202795301014V0081030003 

B  DATE  (MO)  2292900776601014V0012020004 

B  DATE  (DYl)  1313100757201014V0004010005 

B  DATE  (DY2)  1303000756601014V0010010006 

B  PROVl  PFXl  047470079660109  V0014000007 

B  PROVl  PFX2  0464600786601014V0013010008 

B  PROVl  CODE  1454201797001014V0040040009 

B  VISIT  COUNT  2151500777106024V0002010010 
B  PROVl  TIME  SPENT  1464401574801014V0030030011 
B  PROV2  PFXl  040400079660109  V0014000012 

B  PROV2  PFX2  0393900786601024V0013010013 

B  PROV2  CODE  1383501797001024V0040040014 

B  PROV2  TIME  SPENT  1383601574801024V0030030015 
B  UNIT  ID  CODE  0120202450901024V0222060016 
B  TIME  PREP  (1)  1464401372801024V0030030017 

B  TIME  PREP  (2)  1383601372801024V0030030018 

B  TIME  TRAV  (1)  1464401170801024V0030030019 

B  TIME  TRAV  (2)  1383601170801024V0030030020 

B#  ARMY  ACTIVE  DUT  1282601524301024V0030030021 
B#  OTHER  ACTIVE  DUT1282601342501024V0030030022 
B  #  RETIRED  MILT  1222001342501024V0030030023 
^  B  #  DEPENDENTS  1282601170801024V0030030024 

B  #  CIVILIANS  1222001170801024V0030030025 
BCONTIN  SHEET  USED  211110004040011  V0001010026 
BUNL  REASON  (PROC)  1090102091801024V0050050027 
B  REASON  (PROC)  A  247470006100109  V0005000028 
B  REASON  (PROC)  B  247470013170109  V0005000029 
B  REASON  (PROC)  C  247470019230109  V0005000030 
B  REASON  (PROC)  D  247470025350109  V0011000031 
B  REASON  (PROC)  E  247470037370009  V0001000032 
B  REASON  (PROC)  F  247470039400109  V0002000033 
B  REASON  (PROC)  G  247470042450109  V0004000034 
B  REASON  (PROC)  H  247470047510109  V0005000035 
B  REASON  (PROC)  I  235350006110109  V0006000036 
B  REASON  (PROC)  J  235350014190109  V0006000037 
B  REASON  (PROC)  K  235350022250109  V0004000038 
B  REASON  (PROC)  L  235350027300109  V0004000039 
B  REASON  (PROC)  M  235350032330109  V0002000040 
B  REASON  (PROC)  N  235350035370109  V0003000041 
B  REASON  (PROC)  O  235350039390009  V0001000042 
B  REASON  (PROC)  P  235350042440109  V0003000043 
B  REASON  (PROC)  Q  235350047500109  V0004000044 
B  REASON  (PROC)  R  235350052530109  V0002000045 
B  REASON  (PROC)  S  223230006150109  V0010000046 
B  REASON  (PROC)  T  223230018240109  V0007000047 
B  REASON  (PROC)  U  223230027320109  V0006000048 
B  REASON  (PROC)  V  223230034340009  V0001000049 
B  REASOK  (PROC)  W  2232300383800024V0001010050 
F  FILLER  849  490051 


-99- 


ha 


FILLER  849 

FILLER  801 

//EOF0172 


-100- 


490052 

010053 


860  IMMUNIZATION 


SCAN860.FIL 


H02830247NY0051IMMUNIZATION 

H0544 


B  LITHO 

B  CLINIC  PREFIX 
B  CLINIC  CODE 

F  OTHER  UCA 

B  DATE  (MO) 

B  DATE  (DY) 

B  PROVl  PFX 

B  PROVl  CODE 

B  SSN  A 

B  FMP  A 

B  PROC  A1 

B  PROC  A2 

B  ALLERGY  A 

B  SPE  PRE  CODE  A 
B  SSN  B 

B  FMP  B 

B  PROC  B1 

B  PROC  B2 

B  ALLERGY  B 

BSPE  PRE  CODE  B 


SSN  C 
FMP  C 
PROC  Cl 
PROC  C2 
ALLERGY  C 
SPE  PRE  CODE 
SSN  D 
FMP  D 
PROC  D1 
PROC  D2 
BALLERGY  D 
B  SPE  PRE  CODE 
SSN  E 
FMP  E 
PROC  El 
PROC  E2 
ALLERGY  E 
SPE  PRE  CODE 
SSN  F 
FMP  F 
PROC  FI 

BPROC  F 

B  ALLERGY  F 
B  SPE  PRE  CODE 
//EOF0376 


B 

B 

B 

B 

B 

B 

B 

B 

B 

B 


B 

B 

B 

B 

B 

B 

B 

B 

B 


D 


* 
* 

739160104040011  H0024080001 
2080800776902024V0005010002 
0060202785201024V0081030003 
801  010004 
2383800635201014V0012020005 
1424002615201014V0020020006 
0464600785201014V0027010007 
1443802786901014V0040040008 
1422602382901014V0090090009 
1464402382901014V0020020010 
324240046290111  H0018180011 
314140047310111  H0017170012 
310070129290011  V0004040013 
302020037290111  H0009090014 
1422602170801024V0090090015 
1464402170801024V0020020016 
324240025080111  H0018180017 
314140026100111  H0017170018 
310070108080011  V0004040019 
302020016080111  H0009090020 
1432702142301024V0090090021 
1474502142301024V0020020022 
325250006230111  H0018180023 
315150005210111  H0017170024 
311080123230011  V0004040025 
303030015230111  H0009090026 
1432702344301024V0090090027 
1474502344301024V0020020028 
325250026430111  H0018180029 
315150025410111  H0017170030 
311080143430011  V0004040031 
303030035430111  H0009090032 
1432702546301024V0090090033 
1474502546301024V0020020034 
325250046630111  H0018180035 
315150045610111  H0017170036 
311080163630011  V0004040037 
303030055630111  H0009090038 
1432702748301024V0090090039 
1474502748301024V0020020040 
325250066830111  H0018180041 
315150065810111  H0017170042 
311080183830011  V0004040043 
303030075830111  H0009090044 
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900  OCCUPATIONAL  HEALTH  SCAN900.FIL 

H02830247NY00510CCUPATIONAL  HEALTH  * 

H0538  * 

B  LITHO  739160104040011  H0024080001 

B  CLINIC  PFX  2040400706202024V0005010002 

B  CLINIC  CODE  0030101714501024V0081030003 

B  OTHER  UCA  1  212120081800109  V0002000004 

B  OTHER  UCA  2  2060600818100024V0001010005 

B  DATE  (MO)  2434300604901014V0012020006 

B  DATE  (DY)1  1454500585501014V0004010007 

B  DATE  (DY)2  1444400584901014V0010010008 

B  PROVl  PFXl  044440033200109  V0014000009 

B  PROVl  PFX2  0434300322001014V0013010010 

B  PROVl  CODE  1423901332401014V0040040011 

B  SSN  1332501584901014V0090090012 

B  FMP  1373601584901014V0020020013 

B  JOB  REL  IF  YES  2202000323001024V0003010014 

B  PROVl  TIME  2373700351401014V0022020015 

B  PROV2  PFXl  029290033200109  V0014000016 

B  PROV2  PFX2  0282800322001024V0013010017 

B  PROV2  CODE  1272401332401024V0040040018 

B  PROV2  TIME  2313100351401024V0022020019 

B  REAS  FOR  #2  A  230300011090109  V0003000020 
B  REAS  FOR  #2  B  2272501080800024H0003010021 
B  IF  NOT  SCHED  2121200717001024V0002010022 
B  IF  NOT  CLINIC  1  212120063610109  V0003000023 
B  IF  NOT  CLINIC  2  2090701606000024H0003010024 
B  PURPOSE  ILL  2161204555500024H0002010025 

B  PURPOSE  INJ  2161204545400024H0002010026 

B  PURPOSE  A  020200054530109  V0002000027 

B  PURPOSE  B  020200051490109  V0003000028 

B  PURPOSE  C  020200047460109  V0002000029 

B  PURPOSE  D  0131300534701024V0007010030 

B  JOB  REL  217170034340011  V0001010031 

B  MIL  ONLY  DUTY  2202000241410024V0002010032 

B  MIL  ONLY  QTRS  2191900222001024V0003010033 

B  MIL  ONLY  PROF  2191900181501024V0004010034 

F  FILLER  805  050035 

B  SPEC  PRE  CLIN  344360108080011  V0009090036 

B  NOT  AVAIL  320200009070111  H0003030037 

B  PROVl  ADDLl  OUT  2110704060600024H0002010038 
B  ADDL  PROCl  1110701071601024V0050050039 
B  PROV2  ADDL2  OUT  2050104060600024H0002010040 
B  ADDL  PROC2  1050101071601024V0050050041 
F  ADMITTED  801  010042 

BUNL  REAS  PRIM  PFX  2121200747602024V0002010043 
B  UNL  REAS  PRIM  1110701748301034V0050050044 

B  UNL  REAS  SEC  PFX  2060600747602024V0002010045 
B  UNL  REAS  SEC  1050101748301034V0050050046 

B  R/0  238380036360011  V0001010047 

B  PROC  PROVl  (A)  347470009170111  H0009090048 

B  PROC  PROVl  (B)  347470019250111  H0007070049 

B  PROC  PROVl  (C)  347470027320111  H0006060050 

B  PROC  PROVl  (D)  335350008100111  H0003030051 
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B  PROC  PROVl  (E)  335350012230111  H0012120052 
B  PROC  PROVl  (F)  335350025320111  H0008080053 
B  PROC  PROVl  (G)  323230008110111  H0004040054 
B  PROC  PROVl  (H)  323230013200111  H0008080055 
B  PROC  PROVl  (I)  323230022320111  H0011110056 
B  PROC  PROVl  (J)  311110019310111  H0013130057 
B  PROC  PROV2  (A)  346460009170111  H0009090058 
B  PROC  PROV2  (B)  346460019250111  H0007070059 
B  PROC  PROV2  (C)  346460027320111  H0006060060 
B  PROC  PROV2  (D)  334340008100111  H0003030061 
B  PROC  PROV2  (E)  334340012230111  H0012120062 
B  PROC  PROV2  (F)  334340025320111  H0008080063 
B  PROC  PROV2  (G)  322220008110111  H0004040064 
B  PROC  PROV2  (H)  322220013200111  H0008080065 
B  PROC  PROV2  (I)  322220022320111  H0011110066 
B  PROC  PROV2  (J)  310100019310111  H0013130067 
B  PROC  OUT  (A)  345450009170111  H0009090068 
B  PROC  OUT  (B)  345450019250111  H0007070069 
B  PROC  OUT  (C)  345450027320111  H0006060070 
B  PROC  OUT  (D)  333330008100111  H0003030071 
B  PROC  OUT  (E)  333330012230111  H0012120072 
B  PROC  OUT  (F)  333330025320111  H0008080073 
B  PROC  OUT  (G)  321210008110111  H0004040074 
B  PROC  OUT  (H)  321210013200111  H0008080075 
B  PROC  OUT  (I)  321210022320111  H0011110076 
B  PROC  OUT  (J)  309090019310111  H0013130077 
B  OTHER  CODES  (A)  343430042390111  H0004040078 
B  OTHER  CODES  (B)  337370042390111  H0004040079 
B  OTHER  CODES  (C)  331310042390111  H0004040080 
B  OTHER  CODES  (D)  325250042390111  H0004040081 
B  OTHER  CODES  (E)  319190042390111  H0004040082 
B  DXl  COLl  (A)  247470040430109  V0004000083 
B  DXl  COLl  (B)  247470046480109  V0003000084 
B  DXl  COLl  (C)  247470051570109  V0007000085 
B  DXl  COLl  (D)  247470061630109  V0003000086 
B  DXl  COLl  (E)  247470066730109  V0008000087 
B  DXl  COLl  (F)  2474700768301024V0008020088 
B  DXl  COL2  (A)  235350038430109  V0006000089 
B  DXl  COL2  (B)  235350046560109  V0011000090 
B  DXl  COL2  (C)  235350058610109  V0004000091 
B  DXl  COL2  (D)  235350064660109  V0003000092 
B  DXl  COL2  (E)  235350069710109  V0003000093 
B  DXl  COL2  (F)  2353500748201024V0009020094 
B  DXl  COL3  (A)  223230038510109  V0014000095 
B  DXl  COL3  (B)  223230054710109  V0018000096 
B  DXl  COL3  (C)  223230073730009  V0001000097 
B  DXl  COL3  (D)  223230076790109  V0004000098 
B  DXl  COL3  (E)  2232300818201024V0002020099 
B  DXl  COL4  (A)  211110037470109  VOOllOOOlOO 
B  DXl  COL4  (B)  211110049490009  VOOOIOOOIOI 
B  DXl  COL4  (C)  211110052550109  V0004000102 
B  DXl  COL4  (D)  211110057610109  V0005000103 
B  DXl  COL4  (E)  2111100646801024V0005020104 
B  DX2  (A)  346460040430111  H0004040105 
B  DX2  (B)  346460046480111  110003030106 


pQncQCQnDQAaancQnncooQnEQPQpaoQcQCQ 
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DISPOSITIONS 
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346460051570111 

346460061630111 

346460066730111 

346460076830111 

334340038430111 

334340046560111 

334340058610111 

334340064660111 

334340069710111 

334340074820111 

322220038510111 

322220054710111 

322220073730011 

322220076790111 

322220081820111 

310100037470111 

310100049490011 

310100052550111 

310100057610111 

310100064670111 

308080041170211 


H0007070107 

H0003030108 

H0008080109 

H0008080110 

H0006060111 

H0011110112 

H0004040113 

H0003030114 

H0003030115 

H0009090116 

H0014140117 

H0018180118 

H0001010119 

H0004040120 

H0002020121 

H0011110122 

H0001010123 

H0004040124 

H0005050125 

H0004040126 

H0013130127 
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910  OCCUPATIONAL  THERAPY  REPEAT 


SCAN910.FIL 


H02830247NY0000OT  REPEAT  * 
H0539  * 
B  LITHO  739160104040011  H0024080001 
B  SSN  1443601756601014V0090090002 
B  FMP  1474601756601014V0020020003 
B  OTHER  REF  1  220200082660209  V0009000004 
B  OTHER  REF  2  2161600826602024V0009020005 
B  REF  CODE  PFX  2111100786802024V0006010006 
B  REF  CODE  (lA)  009090079660109  V0014000007 
B  REF  CODE  (IB)  0080800786601024V0013010008 
B  REF  CODE  (2A)  006060079660109  V0014000009 
B  REF  CODE  {2B)  0050500786601024V0013010010 
B  REF  CODE  (3A)  003030079660109  V0014000011 
B  REF  CODE  (3B)  0020200786601024V0013010012 
B  DX  PFX  2343400757302024V0002010013 
B  DX  1332901756601034V0050050014 
B  DATE  (MO)  1  2424200615001014V0012020015 
B  DATE  (DY)  1  1464402595001014V0020020016 
B  PROVl  PFX  lA  024240059460109  V0014000017 
B  PROVl  PFX  IB  0222200584601014V0013010018 
B  PROVl  CODE  1  1201402595001014V0040040019 
B  PROVl  TIME  lA  220200048450109  V0004000020 
B  PROVl  TIME  IB  2161600484501014V0004010021 
B  PROV2  PFX  lA  012120059460109  V0014000022 
B  PROV2  PFX  IB  0101000584601024V0013010023 
B  PROV2  CODE  1  1080202595001024V0040040024 
B  PROV2  TIME  lA  208080048450109  V0004000025 
B  PROV2  TIME  IB  2040400484501024 V0004010026 
B  REASON  FOR  #2  lA  208080041390109  V0003000027 
B  REASON  FOR  #2  IB  206020237370009  H0003000028 
B  REASON  FOR  #2  1C  2080800424200024V0001010029 
B  VISIT  COUNT  lA  224240038360109  V0003000030 
B  VISIT  COUNT  IB  222220038360109  V0003000031 
B  VISIT  COUNT  1C  2202000383601024V0003010032 
B  UNLISTED  PROC  1  1463802453601024V0050050033 
B  PROC  PROVl  1  336360061360111  H0026260034 
B  PROC  PROV2  1  334340061360111  H0026260035 
B  DATE  (MO)  2  2424200312001024V0012020036 
B  DATE  (DY)  2  1464402292001024V0020020037 
B  PROVl  PFX  2A  024240029160109  V0014000038 
B  PROVl  PFX  2B  0222200281601024V0013010039 
B  PROVl  CODE  2  1201402292001024V0040040040 
B  PROVl  TIME  2A  220200018150109  V0004000041 
B  PROVl  TIME  2B  2161600181501024V0004010042 
B  PROV2  PFX  2A  012120029160109  V0014000043 
B  PROV2  PFX  2B  0101000281601024V0013010044 
B  PROV2  CODE  2  1080202292001024V0040040045 
B  PROV2  TIME  2  208080018150109  V0004000046 
B  PROV2  TIME  2A  2040400181501024V0004010047 
B  REAS  FOR  #2  2A  208080011090109  V0003000048 
B  REAS  FOR  #2  2B  206020207070009  H0003000049 
B  REAS  FCR  :?2  2C  2080800121200024V0001010050 
B  VISIT’  COUNT  2A  224240008060109  V0003000051 
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B  VISIT  COUNT  2B  222220008060109  V0003000052 
B  VISIT  COUNT  2C  2202000080601024V0003010053 
B  UNLISTED  PROC  2  1463802150601024V0050050054 
B  PROC  PROVl  2  336360031060111  H0026260055 
B  PROC  PROV2  2  334340031060111  H0026260056 
B  DATE  (MO)  3  2434300092001024V0012020057 
B  DATE  (DY)  3  1474502112001024V0020020058 
B  PROVl  PFX  3A  025250011240109  V0014000059 
B  PROVl  PFX  3B  0232300122401024V0013010060 
B  PROVl  CODE  3  1211502112001024V0040040061 
B  PROVl  TIME  3A  221210022250109  V0004000062 
B  PROVl  TIME  3B  2171700222501024V0004010063 
B  PROV2  PFX  3A  013130011240109  V0014000064 
B  PROV2  PFX  3B  0111100122401024V0013010065 
B  PROV2  CODE  3  1090302112001024V0040040066 
B  PROV2  TIME  3A  209090022250109  V0004000067 
B  PROV2  TIME  3B  2050500222501024V0004010068 
B  REASON  FOR  #2  3A  209090029310109  V0003000069 
B  REASON  FOR  #2  3B  207030233330009  H0003000070 
B  REASON  FOR  #2  3C  2090900282800024V0001010071 
B  VISIT  COUNT  3A  225250032340109  V0003000072 
B  VISIT  COUNT  3B  223230032340109  V0003000073 
B  VISIT  COUNT  3C  2212100323401024V0003010074 
B  UNLISTED  PROC  3  1473902253401024V0050050075 
B  PROC  PROVl  3  337370009340111  H0026260076 
B  PROC  PROV2  3  335350009340111  H0026260077 
B  DATE  (MO)  4  2434300395001024V0012020078 
B  DATE  (DY)  4  1474502415001024V0020020079 
B  PROVl  PFX  4A  025250041540109  V0014000080 
B  PROVl  PFX  4B  0232300425401024V0013010081 
B  PROVl  CODE  4  1211502415001024V0040040082 
B  PROVl  TIME  4A  221210052550109  V0004000083 
B  PROVl  TIME  4B  2171700525501024V0004010084 
B  PROV2  PFX  4A  013130041540109  V0014000085 
B  PROV2  PFX  4B  0111100425401024V0013010086 
B  PROV2  CODE  4  1090302415001024V0040040087 
B  PROV2  TIME  4A  209090052550109  V0004000088 
B  PROV2  TIME  4B  2050500525501024V0004010089 
B  REASON  FOR  #2  4A209090059610109  V0003000090 
B  REASON  FOR  #2  4B  207030263630009  H0003000091 
B  REASON  FOR  #2  4C  2090900585800024V0001010092 
B  VISIT  COUNT  4A  225250062640109  V0003000093 
B  VISIT  COUNT  4B  223230062640109  V0003000094 
B  VISIT  COUNT  4C  2212100626401024V0003010095 
B  UNLISTED  PROC  4  1473902556401024V0050050096 
B  PROC  PROVl  4  337370039640111  H0026260097 
B  PROC  PROV2  4  335350039640111  H0026260098 
//EOF0331 
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920  PHYSICAL  THERAPY  REPEAT  SCAN920.FIL 

H02830247NY0000PT  REPEAT 
H0542 

B  LITHO  739160104040011  H0024080001 

B  SSN  1443601756601014V0090090002 

B  FMP  1474601756601014V0020020003 

B  OTHER  REF  1  220200082660209  V0009000004 

B  OTHER  REF  2  2161600826602024V0009020005 

B  REF  CODE  PFX  2111100786802024V0006010006 
B  REF  CODE  (lA)  009090079660109  V0014000007 
B  REF  CODE  (IB)  0080800786601024V0013010008 
B  REF  CODE  (2A)  006060079660109  V0014000009 

B  REF  CODE  (2B)  0050500786601024V0013010010 

B  REF  CODE  (3A)  003030079660109  V0014000011 

B  REF  CODE  (3B)  0020200786601024V0013010012 

B  DX  PFX  2343400757302024V0002010013 

B  DX  1332901756601034V0050050014 

B  DATE  (MO)  1  2424200615001014V0012020015 

B  DATE  (DY)  1  1464402595001014V0020020016 

B  PROVl  PFX  lA  024240059460109  V0014000017 

B  PROVl  PFX  IB  0222200584601014V0013010018 

B  PROVl  CODE  1  1201402595001014V0040040019 

B  PROVl  TIME  lA  220200048450109  V0004000020 
B  PROVl  TIME  IB  2161600484501014V0004010021 
B  PROV2  PFX  lA  012120059460109  V0014000022 

B  PROV2  PFX  IB  0101000584601024V0013010023 

B  PROV2  CODE  1  1080202595001024V0040040024 

B  PROV2  TIME  lA  208080048450109  V0004000025 

B  PROV2  TIME  IB  2040400484501024V0004010026 

B  REASON  FOR  #2  lA  208080041390109  V0003000027 
B  REASON  FOR  #2  IB  206020237370009  H0003000028 
B  REASON  FOR  #2  1C  2080800424200024V0001010029 
B  VISIT  COUNT  lA  224240038360109  V0003000030 
B  VISIT  COUNT  IB  222220038360109  V0003000031 
B  VISIT  COUNT  1C  2202000383601024V0003010032 
B  UNLISTED  PROC  1  1463802453601024V0050050033 
B  PROC  PROVl  1  336360061360111  H0026260034 

B  PROC  PROV2  1  334340061360111  H0026260035 

B  DATE  (MO)  2  2424200312001024V0012020036 

B  DATE  (DY)  2  1464402292001024V0020020037 

B  PROVl  PFX  2A  024240029160109  V0014000038 

B  PROVl  PFX  2B  0222200281601024V0013010039 

B  PROVl  CODE  2  1201402292001C- 4V0040040040 

B  PROVl  TIME  2A  220200018150109  V0004000041 

B  PROVl  TIME  2B  2161600181501024V0004010042 

B  PROV2  PFX  2A  012120029160109  V0014000043 

B  PROV2  PFX  2B  0101000281601024V0013010044 

B  PROV2  CODE  2  1080202292001024V0040040045 

B  PROV2  TIME  2  208080018150109  V0004000046 

B  PROV2  TIME  2A  2040400181501024V0004010047 

B  REAS  FOR  #2  2A  208080011090109  V0003000048 
B  REAS  FOP  #2  2B  206020207070009  H0003000049 
B  REAS  Fi..;;  2  2C  208080012 1200024V0001010050 

B  VISIT  COUNT  2A  224240008060109  V0003000051 


B  VISIT  COUNT  2B  222220008060109  V0003000052 
B  VISIT  COUNT  2C  2202000080601024V0003010053 
B  UNLISTED  PROC  2  1463802150601024V0050050054 
B  PROC  PROVl  2  336360031060111  H0026260055 
B  PROC  PROV2  2  334340031060111  H0026260056 
P  DATE  (MO)  3  2434300092001024V0012020057 
B  DATE  (DY)  3  1474502112001024V0020020058 
B  PROVl  PFX  3A  025250011240109  V0014000059 
B  PROVl  PFX  3B  0232300122401024V0013010060 
B  PROVl  CODE  3  1211502112001024V0040040061 
B  PROVl  TIME  3A  221210022250109  V0004000062 
B  PROVl  TIME  3B  2171700222501024V0004010063 
B  PROV2  PFX  3A  013130011240109  V0014000064 
B  PROV2  PFX  3B  0111100122401024V0013010065 
B  PROV2  CODE  3  1090302112001024V0040040066 
B  PROV2  TIME  3A  209090022250109  V0004000067 
B  PROV2  TIME  3B  2050500222501024V0004010068 
B  REASON  FOR  #2  3A  209090029310109  V0003000069 
B  REASON  FOR  #2  3B  207030233330009  H0003000070 
B  REASON  FOR  #2  3C  2090900282800024V0001010071 
B  VISIT  COUNT  3A  225250032340109  V0003000072 
B  VISIT  COUNT  3B  223230032340109  V0003000073 
B  VISIT  COUNT  3C  2212100323401024V0003010074 
B  UNLISTED  PROC  3  1473902253401024V0050050075 
B  PROC  PROVl  3  337370009340111  H0026260076 
B  PROC  PROV2  3  335350009340111  H0026260077 
B  DATE  (MO)  4  2434300395001024V0012020078 
B  DATE  (DY)  4  1474502415001024V0020020079 
B  PROVl  PFX  4A  025250041540109  V0014000080 
B  PROVl  PFX  4B  0232300425401024V0013010081 
B  PROVl  CODE  4  1211502415001024V0040040082 
B  PROVl  TIME  4A  221210052550109  V0004000083 
B  PROVl  TIME  4B  2171700525501024V0004010084 
B  PROV2  PFX  4A  013130041540109  V0014000085 
B  PROV2  PFX  4B  0111100425401024V0013010086 
B  PROV2  CODE  4  1090302415001024V0040040087 
B  PROV2  TIME  4A  209090052550109  V0004000088 
B  PROV2  TIME  4B  2050500525501024V0004010089 
B  REASON  FOR  #2  4A209090059610109  V0003000090 
B  REASON  FOR  #2  4B  207030263630009  H0003000091 
B  REASON  FOR  #2  4C  2090900585800024V0001010092 
B  VISIT  COUNT  4A  225250062640109  V0003000093 
B  VISIT  COUNT  4B  223230062640109  V0003000094 
B  VISIT  COUNT  4C  2212100626401024V0003010095 
B  UNLISTED  PROC  4  1473902556401024V0050050096 
B  PROC  PROVl  4  337370039640111  H0026260097 
B  PROC  PROV2  4  335350039640111  H0026260098 
//EOF0331 


930  REPEAT  FORM 


SCAN930.FIL 


H02830247NY0051REPEAT  PROCEDURE  * 
H0144 

B  LITHO  739160104040011  H0024080001 
B  CLINIC  PFX  2111100766802024V0005010002 
B  CLINIC  CODEl  0101000776601024V0012010003 
B  CLINIC  CODE2  0090801775101024V0054020004 
B  OTHER  UCA  2151500785802024V0011020005 
F  TODAY'S  DATE  804  040006 
F  PROVl  PFX  801  010007 
F  PROVl  CODE  804  040008 
B  SSN  1433501635401014V0090090009 
B  FMP  1464501635401014V0020020010 
B  VISIT  COUNTl  215150046440109  V0003000011 
B  VISIT  COUNT2  213130046440109  V0003000012 
B  VISIT  COUNT3  2111100464401024V0003010013 
B  PROV  TIME  2232300634301014V0021020014 
B  REF  CODE  PFX  2050500766602024V0006010015 
B  REF  CODE  1  0040400776601024V0012010016 
B  REF  CODE  2  0030201775101024V0054020017 
B  PROC  CODE  1242001776801014V0050050018 
B  DX  PFX  2323200636102024V0002010019 
B  DX  CODE  1312701635401034V0050050020 
B  DATE  (MO)  A  2434300362501014V0012020021 
B  DATE  (DY)  A1  1454500343101014V0004010022 
B  DATE  (DY)  A2  1444400342501014V0010010023 
B  PROV  PFX  (1)  A  045450020070109  V0014000024 
B  PROV  PFX  (2)  A  0444400190701014V0013010025 
B  PROV  CODE  A  1434001201101014V0040040026 
B  DATE  (MO)  B  2343400362501024V0012020027 
B  DATE  (DY)  B1  1363600343101024V0004010028 
B  DATE  (DY)  B2  1353500342501024V0010010029 
B  PROV  PFX  (1)B  036360020070109  V0014000030 
B  PROV  PFX  (2)B  0353500190701024V0013010031 
B  PROV  CODE  B  1343101201101024V0040040032 
B  DATE  (MO)  C  2252500362501024V0012020033 
B  DATE  (DY)  Cl  1272700343 101024V0004010034 
B  DATE  (DY)  C2  1262600342501024V0010010035 
B  PROV  PFX  (1)C  027270020070109  V0014000036 
B  PROV  PFX  (2)C  0262600190701024V0013010037 
B  PROV  CODE  C  1252201201101024V0040040038 
B  DATE  (MO)  D  2161600362501024V0012020039 
B  DATE  (DY)  D1  1181800343101024V0004010040 
B  DATE  (DY)  D2  1171700342501024V0010010041 
B  PROV  PFX  (1)D  018180020070109  V0014000042 
B  PROV  PFX  (2)D  0171700190701024V0013010043 
B  PROV  CODE  D  1161301201101024V0040040044 
B  DATE  (MO)  E  2070700362501024V001202004 5 
B  DATE  (DY)  El  1090900343101024V0004010046 
B  DATE  (DY)  E2  1080800342501024V0010010047 
B  PROV  PFX  (1)E  009090020070109  V0014000048 
B  PROV  PFX  (2)E  0080800190701024V0013010049 
B  PROV  CC»DE  E  1070401201101024V0040040050 
//EOF0091 
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940  SHORT  FORM 


SCAN940.FIL 


H02830247NY0051SHORT  FORM 
H0543 


B 
B 
B 
B 
B 
B 

BDATE 
B 
B 
B 
B 
B 
B 
B 
B 
B 

BSP  PRE 
B 
B 
B 
B 
B 
B 
B 
B 
B 
B 
B 
B 
B 
B 
B 
B 
B 
B 
B 
B 
B 
B 
B 
B 
B 
B 
B 
B 
B 
B 
B 
B 


LITHO 

CLINIC  PREFIX 

CLINIC  CODE  1 

CLINIC  CODE  2 
DATE  (MO) 
DATE  (DY)1 
(DY)  2 
PROV  PFX 
PROV  CODE 
SSN  A 
FMP  A 
TIME  lA 
TIME  2A 
TIME  3A 
UNL  PROC  A 
PROC  A 
CLIN  A 
SSN  B 
FMP  B 
TIME  IB 
TIME  2B 
TIME  3B 
UNL  PROC  B 
PROC  B 

SP  PRE  CLIN  B 
SSN  C 
FMP  C 
TIME  1C 
TIME  2C 
TIME  3C 
UNL  PROC  C 
PROC  C 

SP  PRE  CLIN  C 
SSN  D 
FMP  D 
TIME  ID 
TIME  2D 
TIME  3D 
UNL  PROC  D 
PROC  D 

SP  PRE  CLIN  D 
SSN  E 
FMP  E 
TIME  IE 
TIME  2E 
TIME  3E 
UNL  PROC  E 
PROC  E 

SP  PRE  CLIN  E 


* 
* 

739160104040011  H00240800C1 
2323200787002014V0005010002 
0303000796801014V0012010003 
0282602795301014V0054020004 
2383800604901014V0012020005 
1424200585501014V0004010006 
1404000584901014V0010010007 
0464600795301014V0027010008 
1443802786901014V0040040009 
1422602362701014V0090090010 
1464402362701014V0020020011 
212120043410109  V0003000012 
208080043410109  V0003000013 
2040400434101014V0003010014 
1100202362701024V0050050015 
324240043280111  H0016160016 
322140126260011  V0009090017 
1422602160701024V0090090018 
1464402160701024V0020020019 
212120023210109  V0003000020 
208080023210109  V0003000021 
2040400232101024V0003010022 
1100202160701024V0050050023 
324240023080111  H0016160024 
322140106060011  V0009090025 
1432702132201024V0090090026 
1474502132201024V0020020027 
213130006080109  V0003000028 
209090006080109  V0003000029 
2050500060801024V0003010030 
1110302132201024V0050050031 
325250006210111  H0016160032 
323150123230011  V0009090033 
1432702334201024V0090090034 
1474502334201024V0020020035 
213130026280109  V0003000036 
209090026280109  V0003000037 
2050500262801024V0003010038 
1110302334201024V0050050039 
325250026410111  H0016160040 
323150143430011  V0009090041 
1432702536201024V0090090042 
1474502536201024V0020020043 
213130046480109  V0003000044 
209090046480109  V0003000045 
2050500464801024V0003010046 
1110302536201024V0050050047 
325250046610111  H0016160048 
323150163630011  V0009090049 


//EOF0231 
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950  SOCIAL  WORK  SHORT  FORM 


SCAN950.FIL 


H02830247NY0051SOCIAL  WORK  SHORT  * 
H0545  * 
B  LITHO  739160104040011  H0024080001 
F  OTHER  UCA  801  010002 
B  DATE  (MO)  2424200776601014V0012020003 
B  DATE  (DY)1  1464600757201014V0004010004 
B  DATE  (DY)2  1444400756601014V0010010005 
B  PROVl  PFXl  035350077640109  V0014000006 
B  PROVl  PFX2  0343400766401014V0013010007 
B  PROVl  CODE  1322602776801014V0040040008 
B  SSN  A  1422602534401014V0090090009 
B  FMP  A  1464402534401014V0020020010 
B  REF  CODE  PFX  A  2464600372902024V0005010011 
B  REF  CODE  A  0444002381201024V0081030012 
B  TIME  1  A  236360012090109  V0004000013 
B  TIME  2  A  2303000120901014V0004010014 
B  UNL  PROC  A  1362802241501024V0050050015 
B  PROBLEM  A  2363600413601014V0006010016 
B  PROCEDURE  A  336360033290111  H0005050017 
B  SP  PRE  CLIN  A  346380106060011  V0009090018 
B  SSN  B  1180202534401024V0090090019 
B  FMP  B  1222002534401024V0020020020 
B  REF  CODE  PFX  B  2222200372902024V0005010021 
B  REF  CODE  B  0201602381201024V0081030022 
B  TIME  1  B  212120012090109  V0004000023 
B  TIME  2  B  2060600120901024V0004010024 
B  UNL  PFlOC  B  1120402241501024V0050050025 
B  PROBLEM  B  2121200413601024V0006010026 
B  PROCEDURE  B  312120033290111  H0005050027 
B  SP  PRE  CLIN  B  322140106060011  V0009090028 
B  SSN  C  1432702162501024V0090090029 
B  FMP  C  1474502162501024V0020020030 
B  REF  CODE  PFX  C  2474700324002024V0005010031 
B  REF  CODE  C  0454102315701024V0081030032 
B  TIME  1  C  237370057600109  V0004000033 
B  TIME  2  C  2313100576001024V0004010034 
B  UNL  PROC  C  1372902455401024V0050050035 
B  PROBLEM  C  2373700283301024V0006010036 
B  PROCEDURE  C  337370036400111  H0005050037 
B  SP  PRE  CLIN  C  347390163630011  V0009090038 
B  SSN  D  1190302162501024V0090090039 
B  FMP  D  1232102162501024V0020020040 
B  REF  CODE  PFX  D  2232300324002024V0005010041 
B  REF  CODE  D  0211702315701024V0081030042 
B  TIME  1  D  213130057600109  V0004000043 
B  TIME  2  D  2070700576001024V0004010044 
B  UNL  PROC  D  1130502455401024V0050050045 
B  PROBLEM  D  2131300283301024V0006010046 
B  PROCEDURE  D  313130036400111  H0005050047 
B  SP  PRE  CLIN  D  323150163630011  V0009090048 
//EOF0162 
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APPENDIX  B 


PC  BASIC  SCANNER  PROGRAMS 
TABLE  OF  CONTENTS 


RACP2OO.I1ST 

RACP300.LST 

RACPGEN.LST 

RACP800.LST 

RACP820.LST 

RACP830.LST 

RACP850.LST 

RACP860.LST 

RACP900.LST 

RACP910.LST 

RACP920.LST 

RACP930.LST 

RACP940.LST 

RACP950.LST 


Patient  Form 
Provider  Form 
General  Form  (400-790) 
BAS/TMC  Form 
EKG  Form 

Emergency  Room  Form 
Group  I  and  II  Forms 
Immunization  Short  Form 
Occupational  Health  Form 
OT  Repeat  Form 
PT  Repeat  Form 
Repeat  Form 
Short  Form 

Social  Work  Short  Form 


Offset 

Data 

Source  Line 

001 A 

0002 

REM  SLINESIZE:  132 

001A 

0002 

REM  SPACES  I ZE:  66 

001A 

0002 

REM  ST  I TIE:  'RACPZOO  > 

001A 

0002 

REM  SSU8TITLE:  'PATIENT  OESTRING/OECOOE  PROGRAM 

001A 

0002 

REM  SPAGE 

PAGL  1 
n6-08',17 

IBM  Cntn^tfifn  IeAVm  I'^i^nhi  VI .  00 


0 


0 


4 


4 


0 


0 

-* 

i 


L 


RACP200 

PATIENT  OESTRING/OECODE  PKOGRAN 
OffMt  Data  Sourca  Lina 


PAGE  2 
06-08-87 
07:22:23 


IBM  Personal  Confute)  hASit:  coifiilar  VI. 00 


I  NAME:  RXXP200  AMBULATORY  CARE  INFORMATION  SYSTEM 

I  Date:  28  Feb  85  PATIENT  REGISTRATION  PROGRAM 

I  Floyd  Cola 
I  Upd:  21  Nay  85 

I  Upd:  8  Jun  87  Change  nanas  for  new  system  ORB 


PATIENT  OMR  INPUT  PROGRAM 

This  program  reads  the  patient  OMR  data,  converts  various 
fields,  prints  an  error  report  and  produces  the  file: 

PAT  I ENT .DAT 

for  input  to  FOCUS.  NOTE  THAT  THIS  FILE  IS  OPENED  FOR  APPEND 
each  time  the  program  is  run.  Thus,  if  the  file  does  not  exist, 
records  Mill  be  added  to  the  front.  If  the  file  exists,  records 
will  be  added  to  the  end  of  the  current  file.  It  is  intended  that 
the  FOCUS  DIALOGUE  MANAGER  ROUTINE  which  loads  the  data  wilt  delete 
the  data  file  after  the  load  has  been  successfully  acconplished. 


If  there  is  no  valid  user  logged  at  the  time  of  execution,  this 
program  will  chain  to  the  logon  program  RXXPOS,  otherwise, 
the  program  chains  to  program  RXXP10  on  exit. 


REN  SINCLUDE:  'RACDIM.MOO' 


REM  Include  the  DIMENSION  DEFINITIONS 


»•***********«**««*****•*****•••**•«**#*•*•*«*•***•*••**•««•*****«•*•* 


NAME:  RACOIN.NOD 
Date:  28  Feb  8A 


DIMENSION  DEFINITIONS 
Written  by:  Floyd  Cole 


Dimensioned  variables  are  defined  in  this  file. 

It  is  an  included  file  so  it  cannot  be  run  in  a  stand-alone, 
mode. 

This  program  segment  laay  be  laodified,  but  alt  files  containing 
an  include  for  this  segment  must  be  re-compiled  in  order  to 
affect  the  changes  made  here. 

**••*••*••*•  START  OF  DIMENSION  DEFINITION  **•*••••*••*•*•*••••* 


DEFINT  A-Z 

DIM  USERS(2),MOLENGTH(12),OATEERR«3) 


END  OF  DIMENSION  DEFINITIONS 


REM  DIMENSION  STATEMENTS  UNIQUE  TO  THIS  PROGRAM. 


DIM  SHEETREC(1750) 
DIM  PROTOCOL(7) 
DIM  SEXC0DE$(2> 
DIN  CtVCATSCS) 

DIM  A0CATt(3) 

DIM  YN$(3) 


■(MAX.  SIZE  FOR  A  SHEET  FROM  THE  SCANNER) 
■(ARRAY  FOR  SERIAL  BOARD  SETUP  PARAMETERS) 
■(DECODE  FOR  SEX) 

■(DECODE  FOR  CIVILIAN  CATEGORY  ) 

■(OECOOE  FOR  ACTIVE  DUTY  CATEGORY) 

■(YES/NO  ANSWERS  0=?,  1  =  T  ,  2=M  ,  3=X) 


RACP200 

PATIENT  OESTRING/OECOOE  PNOGRAM 


Offset 

001A 

001A 

001A 

oou 

OOTA 

OOTA 

OOTA 

001A 

001A 

OOTA 

OOTA 

OOTA 

OOTA 

OOTA 

OOTA 

OOTA 

OOTA 

OOTA 

OOTA 

OOTA 

OOTA 

OOTA 

OOTA 

OOTA 

OOTA 

OOTA 

OOTA 

OOTA 

OOTA 

OOTA 

OOTA 

OOTA 

OOTA 

OOTA 

OOTA 

OOTA 

OOTA 

OOTA 

OOTA 

OOTA 

OOTA 

OOTA 

OOTA 

OOTA 

00A6 

004; 

0054 

005B 

0062 

0069 

0075 

0075 

007C 

0083 
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Data  Source  Line  IBM  Personal  CoiiRxiter  BASIC:  Coispiler  VT.OO 


0002 

0002 

0002 

0002 

0002 

0002 

0002 

0002 

0002 

0002 

0002 

0002 

0002 

0002 

0002 

0002 

0002 

0002 

0002 

0002 

0002 

0002 

0002 

0002 

0002 

0002 

0002 

0002 

0002 

0002 

0002 

0002 

0002 

0002 

0002 

0002 

0002 

0002 

0002 

0002 

0002 

0002 

0002 

0002 

TTTS 

T1T8 

MTA 

TTTA 

TTTA 

TTTA 

TTTA 

TTTA 

TTTA 

TTTA 


DIM  CAT$(7,T3) 
DIM  ED.MSGS(30) 
DIM  N0CATS(46} 


■(PATIENT  CATEGORT  ARRAY) 

■(ERROR  MESSAGES  FROM  EDIT  ROUTINES) 
■(Other  Category  Array)  Added  06/0T/8S) 


REN  SINCLUDE:  'RACCMN.MOO* 


REM  Include  the  COMMON  AREA  DEFINITION 


*  NAME:  RACCMN.MOO  COMMON  AREA  DEFINITION 

*  Date:  28  Feb  84  Written  by:  Floyd  Cole 

******«***«******«*«*«*«*««**#******************»«*********««*«***i 

COMMON  AREA  DEFINITIONS  WILL  BE  HELD  IN  THIS  FILE.  IT  IS  AN 
INCLUDED  FILE  SO  IT  CANNOT  BE  RUN  IN  A  STAND*ALONE,  MODE. 

This  program  segment  may  be  modified,  but  all  files  containing 
an  include  for  this  segment  must  be  re^compited  in  order  to 
affect  the  changes  isadc  here. 


'••START  OF  COMMON  OEFINITIONS^^^^*^^^^^*^^^*^^^^^^^*^ 


COMMON  FORE, BACK, BOARD, HIDE, EFORE.EBACX.BELLS  ■BASIC  SCREEN  COLORS 
COMMON  HEADERS  •2T  CHARACTER  SCANNER  HEADER  INFO 

COMMON  TEXTS  ■■  AIMING  CHARACTERS  FROM  SCANNER 

COMMON  PGMIDS  ■PROGRAM  OR  FORM  ID 

COMMON  HOLENGTHO  'DAYS  IN  THE  MONTH 

COMMON  USERSO 

•••••••••••••END  OF  COMMON  OEFIMITION^«^^*^^^^^^»^^^*^^*^^^»^ 


REM  SINCLUDE:  ■RACOEF.HOO'  REM  Include  the  DEFAULT  DEFINITIONS 

i************************************«***************«******«********** 

■•  NAME:  RACPOT.DEF  DEFAULT  DEFINITIONS  • 

’•  Date:  28  Feb  84  Written  by:  Floyd  Cole  • 

I **«*«*«***•«***•***************•***•*«•********«***•**«****•***««•**** 

'  Variables  used  in  coomon  that  have  a  default  value  on  start*up 

■  will  be  held  in  this  file.  It  is  an  included  file  so  it  cannot 

■  be  run  in  a  stand*alone  snde.  In  normal  operation,  this  file 

'  should  be  'included'  in  the  main  program  only  (RACPTO.BAS). 

I 

'  This  program  segment  may  be  laodified,  but  all  files  containing 

■  an  include  for  this  segment  must  be  re^compiled  in  order  to 
'  affect  the  changes  made  here. 


'START  OF  DEFAULT  OEFINITION^^^*^"*^' 


FORE  » 

15 

'FOREGROUND  COLOR 

>  INTENSE  WHITE 

BACK  > 

1 

■Background  Color 

>  Light  Blue 

BORO  > 

4 

■BORDER 

«  RED 

HIDE  s 

4 

■ALTERNATE  COLOR 

X  RED 

EFORE'= 

14 

■ERROR  FOREGROUND 

DISPLAY 

E8ACK= 

0 

■ERROR  BACKGROUND 

DISPLAY 

BELLS  > 

■  CHR$(7) 

'Sound  the  bell 

MOLENGTH(I) 

•  31 

■JAN 

HOLENGTH(2) 

«  28 

•FEB  <--MOOIFIEO  IN  SUBROUTINE  RACSSOOO.SUB 

HOLENGTH(3) 

»  31 

•MAR 

RACP200 

PATIENT  DESTRING/OECQOE  PROGRAM 


Offset 

Data 

Source  Line 

008A 

111A 

NOLENGTH(4)  ■  30 

•APR 

0091 

111A 

MOLENGTHlS)  >  31 

•MAY 

0098 

111a 

HOLENGTH(6)  >  30 

•JIM 

009r 

111A 

HOLENGTH(7)  >  31 

•JUL 

00A6 

111A 

HOLENGTH(8)  ■  31 

•AUG 

OOAO 

111A 

MOLENGTH(9)  -  30 

•SEP 

00B4 

111A 

HOLENGTH(IO)  >  31 

•OCT 

OOBB 

111A 

HOLENGTH(II)  >  30 

•NOV 

OOC2 

111A 

MOLENGTH(12)  -  31 

•DEC 

OOC9 

111A 

00C9 

111A 

OATEERRS(O)  •  " 

0002 

111A 

OATEERR$<1)  <  "INVALID 

MONTH" 

OOOB 

111A 

DATEERRS<2)  >  "INVALID 

DAY  ■ 

00E4 

111A 

DATEERR$<3)  «  "DAY  TOO  LARGE  FOR  MONTH  COOED" 

OOEO 

111A 

QOEO 

111A 

MAXLENGTH  «  80 

•HAXIMUN  LENGTH  OF  OUTPUT  RECORD 

00F4 

me 

PADS  « 

•PAD  CHARACTER  FOR  SHORT  RECORDS 

OOFO 

OOFO 

1120 

1120 

1 

•••••••••"•••END  OF  DEFAULT  DEFINITIOM"«"*"""«"""""""""""«" 

OOFO 

1120 

OOFO 

1120 

OOFO 

1120 

KEY  OFF 

0103 

1120 

0103 

1120 

REH 

0103 

1120 

REM 

THE  FOLLOWING  VARIABLES  ARE  UNIQUE  TO  EACH  PROGRAM  AND  MUST 

0103 

1120 

REN 

BE  CHANGED. 

0103 

1120 

REN 

0103 

1120 

PGNTITLS  X  "PATIENT  REGISTRATION" 

01 OC 

1124 

010C 

1124 

PGM  IDS  X  "200" 

•VALUE  RECEIVED  FROM  THE  SCANNER 

0115 

1124 

•IN  HEADER  VARIABLE  'PROGRAMS' 

0115 

1124 

C115 

1124 

OATFILS  X  "PATIENT.OAT"  'FILE  TO  BE  INPUT  TO  FOCUS 

01  IE 

1128 

011E 

1128 

REN 

LENGTH  OF  STRING  RECEIVED 

FROM  THE  OMR.... 

01  IE 

1128 

HEADER  X  21 

0125 

112A 

RESPONSEx  93 

01 2C 

112C 

RECORDLENGTH  x  HEADER  •  RESPONSE 

oisr 

112E 

0137 

112E 

REN 

0137 

112E 

0137 

112E 

BTIMESxTIMES 

•SCAN  START  TIME 

0140 

1132 

0140 

1132 

REM 

CIVILIAN  CATEGORY  TABLE 

l'140 

1132 

CIVCAT$(0)x"??" 

0149 

1132 

CIVCAT$(1)x"GS" 

0152 

1132 

CIVCAT$<2)«"GN" 

015B 

1132 

CIVCATS(3)x"UG" 

0'64 

1132 

CIVCAT$(4)x"WL" 

0160 

1132 

C1VCAT$(5)="WS» 

0176 

1132 

CIVCATS(6)x"NF" 

017F 

1132 

CIVCATt(7)x"CT" 

0188 

1132 

CIVCAT$(8)="OT" 

0.91 

1132 
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RACP200 

PATIENT  DESTRING/DECOOE  PROGRAM 


Offset 

Oata 

Source  Line 

I 

0191 

1132 

REM  ARMY  ACTIVE  OUTY  TABLE 

0191 

1132 

ADCAT$(0)=“?7" 

019A 

1132 

AOCAT$(1)=«0 

H 

01A3 

1132 

AOCAT$(2)*"W 

H 

01AC 

1132 

ADCAT${3)=“E 

H 

01 B5 

1132 

01 BS 

1132 

01 B5 

1132 

REM  PATIENT 

CATEGORY 

01  BS 

1132 

'  CIVILIAN/OTHER 

ARMY 

AIR  FORCE 

01BS 

1132 

CAT$(0,0)  »“ERR“ 

CATKI.O)  »"ERR" 

CATS(2,0)  ="ERR" 

0100 

1132 

CAT$(0,1)  *“ERR“ 

CATSd.l)  «“A10« 

CAT$(2,1)  -"FIO" 

•AD 

01EB 

1132 

CATS{0,2)  »'‘ERR" 

CAT$<1,2)  «"A21“ 

CAT$(2,2)  ."F20" 

•RES  lET 

0206 

1132 

CAT$<0,3)  »“ERR" 

CAT$<1,3)  «“A23" 

CATS<2,3)  »»F20" 

•RES  IDT/AT 

0221 

1132 

CAT${0,4)  «"ERR" 

CAT$<1,4)  =«a24“ 

CATS(2,4)  ="f20" 

•NC  lET 

023C 

1132 

CAT$<0,5)  a«ERR" 

CAT$<1,5)  =“A26“ 

CAT$<2,5)  »»F20" 

•NO  IDT/AT 

0257 

1132 

CATS(0,6)  *'‘ERR» 

CAT$<1,6)  «"A70“ 

CATS(2,6)  ."FTO" 

•ACADEMY  COT 

0272 

1132 

CAT$(0,7)  »«ERR" 

CAT$(1,7)  »"A80'‘ 

CATt(2.7)  ««f80" 

•ROTC  COT 

0280 

1132 

CAT$<0,8)  *«ERR“ 

CAT$<1,8)  •"AS0“ 

CATS(2,a)  •"f50« 

•DEPN  AD 

02AS 

1132 

CAT$(0,9)  «“ERR“ 

CAT$(1,9)  »"A30« 

CAT$(2,9)  •"F30" 

•RETIRED 

02C3 

1132 

CAT$<0,10)*“EHR« 

CATS<1,101="A60" 

CATS<2, 10)«"F60" 

•DEP  RET/OEC 

02DE 

1132 

CAT»(0,11)s“H26‘' 

CAT$(1,11)«"ERR" 

CAT$<2,11)»"ERR" 

•CIVILIAN 

02F9 

1132 

CAT$<0,12)»“H26« 

CAT${1,12)*"ERR" 

CATS(2,12)»"ERR" 

•CIV.  PRE  EMP 

03U 

1132 

CAT$(0,13)»“OTH« 

CAT$(1,13)«“0TH“ 

CAT$(2,13)""0TN" 

032F 

1132 

032F 

1132 

'  NAVY 

MARINE 

COAST  GUARO 

032F 

1132 

CATS(3,0}  »"ERR" 

CAT$(4,0)  •"ERR" 

CATS<5,0)  ="ERR" 

034A 

1132 

CAT$(3,1)  »'>N10" 

CAT$(4,1)  «"M10" 

CAT$<5,1)  •"CIO" 

036S 

1132 

CAT$<3,2)  »«M20“ 

CAT$<4,2)  »"M20" 

CAT$(5,2)  ."C20" 

0380 

1132 

CAT$(3,3)  «"N20" 

CAT$<4,3)  •"M20" 

CATS<5,3}  »"C20" 

039B 

1132 

CATS(3,4)  s«M20" 

CAT$(4,4)  •"M20" 

CATS<5.4)  •»C20" 

03B6 

1132 

CAT$(3,5)  »"N20" 

CAT$(4,5)  •"M20" 

CATS{5,5)  •«C20" 

0301 

1132 

CAT$(3,6)  »"H70" 

CAT$(4,6)  «"ERR" 

CAT$<5,6)  •"CTO" 

•ACADEMY  COT 

03EC 

1132 

CAT$(3,7)  «"N80" 

CATS{4,7)  •"ERR" 

CAT$(5,7)  «"ERR" 

•ROTC  COT 

0407 

1132 

CAT$(3,8)  *"N50" 

CAT$(4,8)  •"M50" 

CAT$(5,8)  «"C50" 

0422 

1132 

CAT$(3,9)  «"N30" 

CAI$(4,9)  •"M30“ 

CAT$(5,9)  *"030" 

0430 

1132 

CAT$(3,10)=«N60“ 

CAT$(4,10)="M60" 

CAT$(5,10)*"C60" 

0458 

1132 

CAT$(3,11)»"ERR“ 

CAT$<4,11)*"ERR" 

CAT$<5,11)»"ERR" 

0473 

1132 

CAT$(3,12>*''ERR" 

CAT$(4,12)="ERR" 

CAT$(5,12)^"ERR" 

048E 

1132 

CAT$(3,13)=“OTH“ 

CAT$(4,13)="0TH" 

CAT${5,13)»“OTH" 

04A9 

1132 

04A9 

1132 

'  USPNS 

OTHER 

04A9 

1132 

CAT${6,0)  a«ERR" 

CAT$(7,0)  •"OTH" 

04BB 

1132 

CATS(6,1)  »“P10" 

CAT$<7,1)  ="ERR" 

04CO 

1132 

CAT$(6,2)  =“P20" 

CAT$(7’2)  •"ERR" 

040F 

1132 

CAT$(6,3)  *<'P20" 

CAT${7,3)  ""ERR" 

04F1 

1132 

CAT$(6,4)  «"P20" 

CAT$<7,4)  ="ERR" 

0503 

1132 

CAT$(6,5)  =”P20" 

CATS(7,5)  ="ERR" 

0515 

1132 

CAT$(6,6)  «''ERR" 

CAT$<7,6)  ="ERR" 

0527 

1132 

CAT$(6,7)  *"ERR" 

CAT$(7,7)  »"ERR" 

0539 

1132 

CATt(6,8)  »"P50" 

CATt(7,8)  ="ERR" 

054B 

1132 

CAr$(6,9)  s"P30" 

CATS(7,9J  •"ERR" 

0550 

1132 

CATS(6,10)*"P60" 

CAT$(7,10)s"ERR" 

056F 

1132 

CAT$(6,11)»"ERR" 

CAT1(7,11)="ERR" 

0581 

1132 

CAT»(6,12)*"ERR” 

CATS(7,12)""ERR" 
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RACP20Q 

PATIENT  DESTRING/DECOOE  PROGRAM 


Offset  Data 


Source  Line 


0593  1132  CATS(6, 13>»"OTH"  :  CAT$(7,13)=“OTH« 

05A5  1132 

05A5  1132  REM  •**  Other  Patient  Category  Table  *** 

OSAS  1132  NOCATS(OO)  >  •HWERR" 

05AE  1132  NOCATSfOl)  *  slSAIO" 

0587  1132  MOCAT$(02)  »  >44010" 

05CO  1132  HOCAT$(03)  »  "45020" 

05C9  1132  NOCAT$(04)  =  "46030" 

0502  1132  M0CATS<05)  «  "47050" 

0508  1132  NOCATS(06)  >  "48060" 

05E4  1132  NOCATS(07)  «  "49H10" 

05E0  1132  NOCATS<08}  >  "50H20" 

05F6  1132  MOCAT$(09)  »  "52H30" 

05FF  1132  NOCATSdO)  «  "53838" 

0608  1132  NOCATSdl)  =  "54H40" 

0611  1132  NOCAT$<12)  «  "55H50" 

061A  1132  M0CAT1(13)  »  "56J10" 

0623  1132  NOCATKU)  *  "57J20" 

062c  1132  NOCATS<15>  >  "S8J30" 

0635  1132  MOCAT$<16)  »  "59IC10" 

063E  1132  NOCATS(17)  •  "60K20" 

0647  1132  NOCATt(18)  ■  "61IC30" 

0650  1132  NOCATKIP)  »  "62W0" 

0659  1132  MOCATS<20)  *  "63K42" 

0662  1132  MOCATS<21)  *  "64K43" 

0668  1132  NOCAT$(22)  =  "651150“ 

3674  1132  NOCATS<23)  •  "67IC50" 

0670  1132  NaAT$(24)  =  "68K51" 

0686  1132  NOCAT$(25)  =  "69IC60" 

068F  1132  NOCAT$<26)  *  "70K70" 

0698  1132  NOCAT$(27)  •  "71010" 

06A1  1132  MOCAT$<28)  »  "72R10" 

06AA  1132  NOCAT$(29)  »  "73S10" 

0683  1132  NOCAT$(30)  *  “74S20“ 

068C  1132  NOCAT*(31)  «  "75S23" 

06C5  1132  NOCAT$(32)  «  "76S24" 

06CE  1132  HOCAT$(33)  •  "77S30" 

0607  1132  MOCAT${34)  »  "78S32" 

06E0  1132  MOCAT$(35)  »  "79S40" 

06E9  1132  NOCAT$<36)  «  "80S50" 

06F2  1132  MOCAT$(37)  «  "81S60" 

06F8  1132  NOCATt(38)  =  "82X10" 

0704  1132  NOCAT$(39)  =  "83X20" 

0700  1132  MOCAT$(40)  =  "84X30" 

0716  1132  MOCAT$(41)  *  "85X40" 

071 F  1132  N0CAT$<42)  =  "86X45" 

0728  1132  NOCATS(43)  *  "87X52" 

0731  1132  NOCAT$(44)  *  "88X60" 

073A  1132  NOCAT$(45)  *  "89X70" 

C,-43  1132 

0743  1132  REM  SEX  TABLE 

07' 3  1132  SEXCOOESIO)’"”'  :  SEXCOOESd  >»"M"  :  SEXC00£t(2)="F" 

'75E  1132 

075E  1132  REM  YES/NO  TABLE 
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RACP200  pace  7 

PATIEMT  DESTRING/DECQOE  PROGRAM  06-CR-87 

07:22:25 

Offset  Data  Source  Line  IBM  Personal  Cctnputer  BASIC  Compiler  VI. 00 

075E  1132  YN$(0>=“7"  :  YM$(1)=''Y"  ; 

0782  1132 

0782  1132  REN  SPAGE 


YM$<2)=“»I“  :  YNt<3)=“X" 


RACP200 

MTtEHT  OESTRING/OECOOE  PROGRAM 


PAGE  a 

06-08-87 
0/;7r:23 

Offset  Osta  Source  Line  IBM  Personal  f.omfuitei  KA'at;  t(«n>ilrr  VI. 00 

0782  1132  GOSUB  1000  'HAKE  SURE  THEY  ARE  LOGGED  ON 

0787  1132  CLS 

0788  1132  GOSUB  7000  'PRINT  SCREEN  HEADING 

0790  1132 

0790  1132  REM 

0790  1132  REM 

0790  1132  REM 

0790  1132  REN 

0790  1132 

07A2  1132 

07A2  1132  REM 

07A2  1132  REM 

07A2  1132  REM 

07A2  1132  REM 

07A2  1132 

07AC  1132 

07B8  1134 

07BP  1134 

07D4  1134 

07EA  1134 

07EA  1134  REM 

07EA  1134  REM 

♦  07EA  1134  REN 
07EA  1134  REM 

07EA  1134 

07EF  1134 

0809  1138 

0809  1138  REM  START  SCANNER  (SI) 

0809  1138  CNTRLOPT  »1  ;GOSU8  9010 

0815  113A  IF  ERRMSGS  >  "  "  THEN  LPRINT  ERRMSCt  :  GOTO  30000 

082F  113A 

082F  113A  LOCATE  22,25:PRINT  "PRESS  'ESC  TO  TERMINATE  SCANNING  " 

0844  113A  READTYPE=3  'FIRST  TIME  IN..  SCANNER  IS  STARTED.. 

0848  113C 

084B  113C  REN 

0848  113C  REM  *•••  SET  SCAN  SHEET  CALL  •*» 

084B  113C  REM 

0848  113C  REM 

0848  113C 

0848  113C  10  REM  -  RETURN  POINT  TO  READ  NEXT  SHEET 

084C  113C 

084C  113C  AS: INKEYS 

0855  1140  IF  AS=CHRS<27)  THEN  GOTO  25000 

u868  1140 

08o8  1140  GOSUB  9020  'SCAN  SUBROUTINE  -  GET  A  RECORD 

Of'O  1140  IF  MIOS(ERRSTATS, 14, THEN  GOTO  25000 

)88C  1 144 

OSaC  1144  TEXTS:""  'CLEAR  THE  INPUT  AREA 

0895  1144  COSUB  8000  'DECODE  HEADER 

089A  1144  GOSUB  8050  'CHECK  FOR  END  OF  JOB/ENO  OF  BATCH 

089F  1144  GOSUB  8200  'DECODE  THE  RESPONSE  POSITIONS 

0TA4  1144  LITHOS  :  MI0S( IEXTS,39,a) 

02B6  1148  COSUB  8070  'CHECK  FOR  SCANNER  ERRORS 

08BB  1148  GOSUB  8100  'FRI'TT  THE  DATA  ON  THE  SCREEN 


COMMUNICATIONS  SETUP 

**•****•**«*************•**••*•***«****************:) 

PROTOCOL 
GOSUB  9001 

IF  ERRMSGS  >  "  "  THEN  LPRINT  ERRMSGS  :  GOTO  30000 


*M***«M*««****ir**:****************  *********:***:**************:* 

••••  CLEAR  AND  OISPUY  PROGRAM  SCREEN 

************<»*  *****************«****M«***  #********************:: 

LPRINT  CHRS(15);  'INCLUDE  FOR  NARROW  PART  PAPER 

WIDTH  "LPT1:“,160 

PAGE  :  0  :  GOSUB  7100  'LINE  PRINTER  HEADING 
COLOR  14 

LOCATE  11,26  :  PRINT  "PATIENT  REGISTRATION  FORM" 

COLOR  FORE, BACK, BORD 


RACP200 

PATIENT 

Offset 

08C0 

08C0 

08C0 

oaco 

08CO 

08C0 

08C0 

08C0 

OSCO 

08C0 

OSCO 

OSCO 

OSCO 

OSCO 

OSCO 

OSCO 

08C7 

08C7 

08C7 

0809 

08EB 

08EB 

OSEB 

08F4 

08F9 

0908 

0910 

0924 

0924 

0924 

0920 

0932 

0932 

093B 

0940 

0964 

096C 

0992 

0992 

0992 

09A4 

09A4 

09AO 

09B2 

09C1 

09C9 

09DD 

0900 

0900 

09EF 

09EF 

09EF 

09F8 

09F0 


PFGE  9 

DESTRING/OECQOE  PROGRAM  06-08- <17 

(17:2:  ;23 

Data  Source  Line  IBM  Personal  Compuf-er  NASH:  i.oa|>ilri  VI. 00 


1148 

1148 

1148 

1148 

1148 

1148 

1148 

1148 

1148 

1148 

1148 

1148 

1148 

1148 

1148 

1148 

114A 

114A 

114A 

114E 

1152 

1152 

1152 

1156 

1156 

1158 

1158 

1158 

1158 

1158 

115C 

115C 

115C 

115C 

115C 

115E 

115E 

115E 

115E 

115E 

115E 

115E 

1t5E 

115E 

115E 

USE 

115E 

115E 

115E 

1162 

1162 

1162 

1162 

1162 


REM 

REN 

REM 

REN 

REM 

REN 

REM 

REM 

REM 

REM 

REM 

REM 


REM  SINCLUOE:  'RXXMEOI .MOD'  INCLUDE  THE  PATIENT  REFORMAT/EDIT 


•*******•*•**********•*••«**«*•«*•*« 


********** 


••••  AMBULATORY  CARE  INFORMATION  SYSTEM  13  APR  85 


SKIP  COLE 

*««« 

MODULE  NAME  ; 

RXXM201 .MOO 

***• 

SCANNER  PROGRAM  «  : 

200-PATIENT  REGISTRATION 

*«*• 

«*«* 

PURPOSE  : 

REFORMAT/EDIT  THE  PATIENT 

**«• 

OMR  RECORD. 

****  RESERVED  LINE  NUMBERS  100-199 

*************************************************************** 


N.ERR  >0  'COUNTS  THE  NUMBER  OF  ERRORS 

REM  PATIENT  ID  (SSN«FMP*OOB) 

100  FMP$«MI0S(TEXT$,31,2) 

OOB$>HIOS(TEXTS,33,6) 

•EDIT  FMP 

110  CK.50101=fMP$ 

GOSUa  5010  'NUMERIC  STRING  CHECK 
IF  RT.5010  «  0  THEN  GOTO  115 
N.ERR«N.ERR+1 

ED.MSG$<N.ERR)="02  PATIENT  FAMILY  MEMBER  PREFIX" 

■EDIT  DOB 

115  CK.5000S*0O8S 

GOSUB  5000  'DATE  CHECK 

CK.5010S::DOaS 

GOSUB  5010  'NUMERIC  STRING  CHECK 

IF  RT.5000  >  0  AND  RT.5010  «  0  THEN  GOTO  120 
N.ERR*N.ERR+1 

ED.MSG$<N.ERR)="03-05  DATE  OF  BIRTH  "  ♦  0ATEERR${RT.5000) 

REM  •••  LITHO  COOE  ••• 

120  LITHOS  >  MIDS(TEXT$,39,8) 

•EDIT  LITHO 

CK.5010S*LITHOS 

GOSUB  5010  'NUMERIC  STRING  CHECK 

IF  RT.5010  «  0  THEN  GOTO  125 
N.ERR^N.ERR+I 

ED.MSGS{N.ERR)=="LITHO  COOE  " 

REM  REGISTRATION  DATE  ••• 

125  ROATES  •  MID$(TEXT$,47,6) 

•EDIT  REGISTRATION  DATE 
CK.5000S-RDATES 
COSUB  5000 


'DATE  CHECK 


RACP200 

PATIENT  DESTRING/DECGOE  PROGRAM 


I 


Off»et  DAta  Source  Line 
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09FO 

1162 

0A06 

1162 

OAOB 

1162 

0A2T 

1162 

0A37 

1162 

OA50 

1162 

OASD 

1162 

REM 

0A5O 

1162 

130 

0A73 

1164 

0A85 

1168 

0A85 

1168 

REM 

0A85 

1168 

135 

0A97 

116C 

0A97 

116C 

REM 

CA97 

116C 

140 

OAAO 

116C 

OABF 

1170 

OABF 

1170 

REM 

OABF 

1170 

145 

0AD5 

1170 

0AE7 

1174 

0AE7 

1174 

REM 

QAiT 

1174 

150 

OAFD 

1174 

OBOF 

1178 

CBOF 

1178 

REM 

OBOF 

1178 

155 

0821 

117C 

0821 

117C 

REM 

0B21 

117C 

160 

0833 

1180 

0B41 

1182 

0B57 

1184 

0B69 

1188 

0B69 

1188 

0B8S 

118C 

0B85 

118C 

0B97 

118C 

0BA9 

1180 

OSAO 

118C 

)BAO 

118C 

REM 

OCAO 

118C 

165 

0HB6 

118C 

OBBO 

118C 

167 

oac5 

118C 

0E34 

118C 

OBEC 

1190 

OBFE 

1190 

ocio 

1190 

0C28 

1190 

0C2C 

1190 

0C2C 

1190 

170 

CC2D 

1190 

CC35 

1190 

CK.5010S«R0ATES 

G0SU8  S010  ■NUMERIC  STRING  CHECK 
IF  RT.5000  »  0  AMO  RT.5010  «  0  THEN  GOTO  130 
N.ERR>N.ERR+1 

E0.MSCS(N.ERR)>'‘06-08  REGISTRATION  DATE  ■  ♦  OATEERRS(RT.5000) 
GENDER 

X:=VAL(HI0S(TEXT$,S3,1)) 

GENOERS>SEXCOOE$(X) 

***  RACE 

RACES>MI0S(TEXTS,54,1) 

•••  VA 

X=VAL<MI0$<TEXT$,55,1)) 

VAS>YNS(X) 

HCI  •** 

X*VAL(MI0S<TEXTS,56,1)) 

HCIS=TNS<X) 

«*•  toy 

X*VAI.(MI0S(TEXTS,57,1» 

T0YS«YN$<X) 

ZIP  **• 

ZIPS=MIDS(TEXT$,58,5) 

•••  PATIENT  CATEGORY 

STATUSS=MI0$<TEXT$,63,13)  'GET  STATUS  VALUE 

STATUS- 1 NSTR<  STATUSS, " 1 " ) 

BRANCH=VAL(MIDS(TEXTS,76,1))  'GET  BRANCH  VALUE 

OTHERS-MIDS(TEXTS, 110,2) 

ST ATS»CAT$<  BRANCH , STATUS ) 

IF  STATS  =  "ERR"  THEN  GOTO  170  'INVALID  COMBINATION 

IF  STATS  «  "OTH"  THEN  GOTO  165 
GOTO  175 

CHECK  FOR  OTHER  COOING 
STATS  =  "ERR" 

LET  X-0 
LET  X-X+1 

IF  X>45  THEN  GOTO  170 
TEMPCATS=LEFTS(N0CATS(X),2) 

IF  TEHPCATS  >  OTHERS  THEN  GOTO  170 
IF  TEHPCATS  <  OTHERS  THEN  GOTO  167 
STATS-R I CHTS{NOCATS(X ) ,3) 

GOTO  175 

REM  invalid  COMBINATION  COOEO 
N.ERR--M.ERR*1 

ED.MSGS(H.ERR)="1b  16  INVALID  BRANCH/STATUS/OTHER  CATEGORY  " 
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Offset  Data  Source  Line  IBM  Personal  Computer  BASIC  Compiler  VI. 00 


0CA9 

1190 

0C49 

1190 

•EDIT 

SSN 

0CA9 

1190 

175 

IF  STATUS  <  11  THEN  SSN»^10t(TEXTt.22,9)  :  GOTO  177 

0C6A 

1194 

IF  STATUS  «  13  THEN  SSItS>M10$<TEXTS,22.9)  :  GOTO  177 

0C8B 

1194 

SSNS^ID$(TEXTS,90,9) 

0C9D 

1194 

0C9D 

1194 

177 

PTIDS  ■  SSH»»FMP$«D0BS 

0CB1 

1198 

0C61 

1198 

CK.5010S«SSNS 

0C8A 

1198 

GOSUB  5010  'NUWRtC  STRING  CHECK 

OCBF 

1198 

IF  RT.5010  >  0  THEN  GOTO  178 

OCCE 

1198 

N.ERR>H.ERR*1 

OC06 

1198 

ED.MSG$(N.ERR):‘*01  22  PATIENT  SOCIAL  SECURITY  NUMBER" 

OCEA 

1198 

OCEA 

1198 

OCEA 

1198 

REH 

•**  FOREIGN  STUDENT  CODE  •** 

OCEA 

1198 

178 

FOREIGNS>  HIDSfTEXTS, 112,3) 

OCFC 

119C 

IF  FOREIGNS  >  «  >  GOTO  150 

ODOE 

119C 

IF  FOREIGNS  •  "000"  GOTO  180 

0020 

119C 

IF  FOREIGNS  >  "227"  GOTO  179 

0032 

119C 

IF  OTHERS  >  "68"  ANO  OTHERS  «  *78"  GOTO  180  *6000  PAIRING 

0059 

119C 

0059 

119C 

179 

N.ERR^N.ERR^I 

0061 

119C 

EO.M$GS(N.ERR)r  "28  FOREIGN  NATIONAL  COOED  ..  NOT  ALLOWED  WITH  THIS  CATEGORY" 

0075 

119C 

0075 

119C 

180 

REH  --END  OF  FOREIGN  NATIONAL  CHECK 

0076 

119C 

0076 

119C 

REM 

AO  ARMY  PREFIX 

0076 

119C 

X  *  VAL(MI0S(TEXTS,77,1)) 

ODBC 

119C 

MILPFXS*  AOCATS(X) 

009E 

11  AO 

009E 

11A0 

REH 

AO  ARMY  PAY  GRADE  ••• 

009E 

11A0 

MILGRAOES=  MI0$<TEXTS,78,2) 

ODBO 

11A4 

OOBO 

11A4 

REM 

•••  AO  ARMY  MOS  *** 

OOBO 

11A4 

H1LM0SS<  HIDS(TEXTS,86,3) 

0OC2 

11A8 

0OC2 

11A8 

REM 

*•*  MILITARY  SSI  ••• 

00C2 

11A8 

NILSSIS^  NI0S(TEXTS,89,1) 

0004 

11AC 

0004 

11AC 

REM 

MILITARY  UNIT 

0004 

11AC 

HILUNITSs  HIDS<TEXTS,8Q,6) 

0OE6 

11B0 

0OE6 

1180 

REN 

FEDERAL  PREFIX 

OOE6 

11B0 

X  »  VAL<MID$(TEXTS,99,1)) 

QOFC 

1110 

'E0PFX$=  CIVCATS(X) 

OEOE 

11B4 

OEOE 

11B4 

REM 

***  FEDERAL  PAT  GRADE  ••• 

OEOE 

1184 

FEDGRADES=  MIDSITEXTS, 100,2) 

0E20 

11B8 

0E20 

11B8 

REM 

•••  FEDERAL  JOB  SERIES  •** 

0E20 

11B8 

FEDJOBCOS=  MIDSITEXTS, 102,4) 

0E32 

11BC 

0E32 

11BC 

REH 

•••  FEDERAL  BUILDING  NO.  **• 

RACP200 
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0E32  11BC  FEDBLOGS>  HI0$(TEXTS, 106,4) 

0E44  11C0 

0644  11C0  REN  DUAL  SSN  NUMBER  •** 

0644  11C0  OUALSSNS-  MIDS(TEXT8,90.9) 

0ES6  11C4 

0E56  11C4  REM  ACTIVE  OOTY  ARMY  EDITS  •** 

0E56  11C4  IF  STATS  <>  aAlO"  GOTO  185 

0668  11C4  IF  HILPFXS  ■  »  ■  THEN  N.ERR<N.ERR»1  :ED.NSGS<N.ERR>c017  MILITARY  PREFIX" 

0C92  11C4  IF  MILGRAOES""  "  THEN  H.ERR«N.ERR«^1  :ED.HSG$<N.ERR)>"18  MILITARY  GRADE  « 

OEBC  11C4  IF  NILNOSS  ■"  "  THEN  N.ERR^H.ERR^I  :ED.MSGS<N.ERR)>"20  MILITARY  MOS  " 

0EE6  11C4  IF  MILSSIS  >"  ■  THEN  N.ERR*N.ERR«1  :ED.MSGS(N.ERR>3"21  MILITARY  SSI  > 

0F10  11C4  IF  NILUNITS  «"  ■  THEN  N.ERR"N.ERR+1  :EO.MSCS<N.ERR)>"19  MILITARY  UIC  ■ 

0F3A  11C4  IF  HILPFXS  -  "W  ■  THEN  GOTO  199 

0F4C  11C4  IF  VAL(MILMOSS)>100  THEN  N.ERR<N.ERR«1  :  ED.HSGS(N.ERR)""20  INVALID  NOS  FOR  OFFICER/ENLISTEO" 

0F79  11C4  GOTO  199 

0F7D  11C4 

0F7D  11C4  185  REM  **•  CIVILIAN  EDITS 

0F7E  11C4  IF  STATS  <>  "H26"  GOTO  199 

0F9O  11C4  IF  FEOPFXS  m  "  «  THEN  N.ERR-H.ERR«1  :ED.HSGS(H.ERR)>"15  CIVILIAN  CATEGORY" 

OFBA  11C4  IF  FEOGRAOES>"  ■  THEN  N.ERR"N.ERR*1  :ED.MSGS(N.ERR)""24  CIVILIAN  GRADE  " 

0FE4  11C4  IF  FEOJOeCOSs"  "  THEN  N.ERR"N.ERR*1  :E0.MSGS(N.ERR)""25  CIVILIAN  SERIES" 

100E  11C4  IF  FEOBLDGS  >"  "  THEN  N.ERR>=N.ERR«1  :ED.HSGS(N.ERR}*"26  CIVILIAN  BLOG" 

1038  11C4  IF  DUALSSNS  <"  "  THEN  N.ERR>N.ERR*1  :ED.MSGS(N.ERR)""27  CIVILIAN  SSN  « 

1062  11C4 

1062  11C4  199  REM 

1063  11C4 

1063  11C4  REM . END  OF  MODULE  RXXM201.M00 . 

1063  11C4 

1063  11C4 

1063  11C4  IF  N.ERR  «  0  THEN  GOTO  997 

1072  11C4  LPRINT  "LITHO  »  ";LITMOS;«  ...  ERRORS" 

1084  11C4  FOR  1200  >  1  TO  N.ERR 

1091  11C6  LPRINT  USING  "###  ";I200; 

1090  11C8  LPRINT  "»«>  ":E0.MSGS(I200) 

10B3  11C8  NEXT  1200 

10C4  lies  LN. COUNT  •  LN. COUNT  *  N.ERR  *  1 

1000  11CA  CNTRLOPT  <  6 

10D7  11CA  GOSUB  9010  ’REJECT  THE  FORM 

me  11CA  GOTO  998  'BYPASS  THE  DISK  WRITER _ 

10E0  11CA 


10E0 

11CA 

997 

REM  S INCLUDE:  'RXXM202.MaO< 

REN  INCLUDE  THE  PATIENT  DISK 

WRITER 

10E1 

11CA 

REM 

10E1 

11CA 

REM 

•  *** 

AMBULATORY  CARE  INFORMATION  SYSTEM  13  APR  85 

*«** 

10E1 

11CA 

REM 

*•*« 

SKIP  COLE 

**** 

10E1 

11CA 

REM 

**** 

MODULE  NAME  : 

RXXN202.MOO 

iOEl 

11CA 

REM 

*«•* 

SCANNER  PROGRAM  «  : 

200-PATIENT  REGISTRATION 

*•** 

10E1 

11CA 

REM 

•**« 

*««* 

10E1 

11CA 

REN 

PURPOSE  ; 

CREATE  AND  WRITE  THE  DISK 

10E1 

11CA 

REM 

RECORD  FOR  INPUT  TO  FOCUS 

*««« 

1JE1 

11CA 

REM 

10E1 

11CA 

REM 

lost 

11CA 

REM 

RESERVED  LINE  NUMBERS 

200-299 

«*** 

'OEI 

11CA 

REM 

10E1  11CA 
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10E1  11CA  REM  BUILD  THE  OUTPUT  RECORD 

10E1  11CA 

10E1  11CA  RECaUT$a>'200''  'TRANSACTION  IDENTIFIER 

10EA  11CE 

IDEA  11CE  RECOUTS*  RECOUTS  *  PTIDS  *  STATS  *LITHOS  *  ROATES  *  GENDERS  «  RACES 

1115  11CE 
1115  11CE 

11'.:  '.:c£  REM  ***  FIND  OUT  IF  WE  HAVE  A  CIVILIAN.  OR  AD  PATIENT  ••• 

1115  11CE 

1115  11CE  IF  LEFTS(STATS,1)*"H«  THEM  GOTO  200 

112E  11CE  IF  LEFTS(STATS,1)x'<J"  THEN  GOTO  200 

1U7  11CE  IF  LEFTSISTATS.I )»••?••  THEN  GOTO  200 

1160  11CE  IF  LEFTSfSTATS, 1 )«"K"  THEN  GOTO  200 

1179  11CE  IF  LEFTS<STATS,1)*'<X«  THEN  GOTO  200 

1192  11CE  IF  LEFT$(STATS,1)*"P"  THEM  GOTO  200 

11AB  11CE  IF  RIGHT$(STAT$,2)>"50'‘  THEN  GOTO  200 

11CA  11CE  IF  RIGHTS(STATS,2}:‘<60‘'  THEN  GOTO  200  'CIVILIAN/DEPENDENT 

HDD  11CE 

HDD  11CE  RECOUTS  ■  RECOUTS  «  HILPFXS  *  HILGRAOES  *  HILMOSS  *  HILSSlS  «  HILUNITS 

1202  11CE 

1202  11CE  GOTO  210 

1206  11CE 

1206  11CE  200  RECOUTS  ■  RECOUTS  ♦  nOPfXS  *  FEOGRAOES  ♦  FEOJOBCPS  ♦  FEDBLDGS*''  ■  if 

122B  11CE 

1228  11CE  210  RECOUTS  a  RECOUTS  ♦  TOYS  «  VAS  «  HCIS  ZIPS 

12AA  11CE  RECOUTS  a  RECOUTS  «  DUALSSNS  *  FOREIGNS 

1250  11CE 

125D  11CE  PAOaMAXLENGTH  •  LEN(RECOUTS)  'FIND  OUT  HOW  SHCHIT  THE  RECORD  IS 

126B  11D0  RECOUTS  >  RECOUTS  +  STR1NGS(PA0,PA0S)  'PAD  THE  RECORD  UITN  FILL  CHAR 


127E  1100 

127E  11D0  PRINT  #1, RECOUTS 

1289  1100 

1289  1100  REM . ENO  OF  MODULE  RXXMZ02.MOO 


1289  1100 

1289  1100 

1289  1100  998  REM  CONTINUE 

128A  1100 

128A  1100  999  REAOTYPE  =  2 

1291  1100  IF  LN. COUNT  >  48  THEM  GOSUB  7100  'PRINTER  HEADING 

12A1  11D0  GOTO  10 

12A5  11D0 

12A5  1100  REM  ENO  OF  SCAN/OECOOE/URITE  LOOP  a=a=«=»«========aa==as«a=a.aa=a=a=a=*= 

12AS  1100 

12A5  1100  1000  REM  SINCLUOE:  'R ACS 1000. SUB'  Include  the  VERIFY  LOGON  SUB 

REM  •  NAME:  RACSIOOO  LOGON  VERIFICATION  SUBROUTINE  • 

REM  *  oate:  28  Feb  84  PATIENT  REGISTRATION  PROGRAM  * 

REM  PATIENT  OMR  INPUT  PROGRAM  * 

REM  * 

REM  This  program  verifies  user  is  logged  on  properly.  If  there  is  no  • 
REM  valid  user  logged  on  at  the  time  of  execution,  this  subroutine  Mill* 
REM  chain  to  the  logon  program  RACP05,  otherwise  a  return  is  issued.  • 
REM 


12A6  11D0 
12A6  11DO 
12A6  1100 
12A6  1100 
12A6  1100 
12A6  1100 
12A6  1100 
12A6  1100 
12A6  1100 
12A6  1100 
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12A6 

12A6 

1100 

1100 

REM 

RESERVEO  LINE  NUMBERS  ARE  1001  THRU  1010 

»•** 

REM  ^ 

"  ”  "  ”  "  ’ 

12A6 

1100 

1001 

OPEN  "1“,1,"11ACL0G.0AT« 

t2S8 

1100 

IF  E0F(1)  THEN  1002 

'MAKE  THEN  LOG  ON  FIRST 

12C6 

1100 

INPUT  «1,USER$(H,0TS,TMS,PI0S 

12E7 

HOC 

IF  USERS(I)  ■  ««  THEM  1002 

•MAKE  THEM  LOG  ON  FIRST 

12F5 

HOC 

IF  USERSd)  «  •«***•*•«  then  1002  ‘MAICE  THEN  LOG  ON  FIRST 

1303 

HOC 

CLOSE  1 

130A 

HOC 

SCREEN  0,1. 0.0 

1320 

HOC 

COLOR  FORE.BACK.BORO 

1336 

HOC 

CLS 

133A 

HOC 

RETURN 

1330 

Hoc 

1330 

HOC 

1002  CLOSE 

1341 

HOC 

CHAIN  "RACPOSo 

1348 

HOC 

Issss 

snxaxnENO  OF  LOGON  VERIFY  SUBROUTINE  1000»*»»m»**»*»**«**s*»«x«»*“ 

1348 

HOC 

1348 

1349 

HOC 

HOC 

2000 

REM 

REM  SINCLUDE:  'RACSaOOO.SUS' 

A  A  MAM  AAAAAtA  M  A  •«! 

Include  the  REPLT/DEUY  SUB 

*** 

1349 

HOC 

REM 

*•**  AMBULATORY  CARE  DATA  BASE  13  APR  85 

**** 

1349 

HOC 

REM 

*•*« 

SKIP  COLE 

1349 

HOC 

REM 

SUBROUTINE  NAME 

RACS2000.SU6 

1349 

HOC 

REM 

*•••  SCANNER  PROGRAM  $ 

ALL 

*««* 

1349 

HOC 

REM 

FUNCTION 

THIS  SUBROUTINE  MODULE 

*•«* 

1349 

HOC 

REM 

•*** 

SERVERS  AS  A  WAIT  AND  REPLY 

1349 

HOC 

REM 

•••« 

ENTRY  MODULE 

*«** 

1349 

Hoc 

REM 

INPUT 

SINGLE  KEYBOARD  ENTRY 

***• 

1349 

HOC 

REM 

*•«* 

•*** 

1349 

HOC 

REM 

OUTPUT 

KEYBOARD  ENTRY  -  UPPER  CASE 

•*«* 

1349 

HOC 

REM 

««** 

1349 

HOC 

REM 

••••  RESERVED  LINE 

1349 

HOC 

REM 

NUMBERS 

2001-2010 

**** 

1349 

HOC 

REN 

1349 

HOC 

2001 

REM  REPLY  FUNCTION 

134  A 

HOC 

2002 

REPLTS»INKEY$  :  IF  REPLY$«""  THEN  2002 

135E 

HEO 

REPLY=ASC(REPLYS) 

1368 

HE2 

IF  REPLY  >  90  THEN  REPLY$=CHR$(REPLY  XOR  32)  'CONVERT  TO  CAPS 

1383 

HE2 

IF  REPLYS  <  "A"  OR  REPLYS  >  "Z"  THEN  REPLY$=“»" 

13AF 

11E2 

RETURN 

13B2 

HE2 

1382 

HE2 

5000 

REN  SINCLUDE:  'RACSSOOO.SUB' 

Include  the  DATE  EDITOR  SUB 

1383 

11E2 

REM 

k**** 

1383 

HE2 

REM 

••••  AMBULATORY  CARE  DATA  BASE  13  APR  85 

AAA* 

1383 

HE2 

REM 

SKIP  COLE 

AAAA 

1383 

HE2 

REM 

••••  SUBROUTINE  NAME 

RXXS5000.SUB 

AAAA 

1383 

HE2 

REM 

••••  SCANNER  PROGRAM  # 

ALL 

AAAA 

1JS3 

HE2 

REN 

FUNCTION 

THIS  SUBROUTINE  MODULE 

AAAA 

1383 

HE2 

REM 

«**« 

PERFORMS  A  DATE  EDIT 

AAAA 

13R3 

HE2 

REN 

***« 

AAAA 

'383 

HE2 

REM 

input 

DATE  TO  BE  CHECKED  MUST  BE 

AAAA 

1363 

11E2 

REN 

**•* 

IN  THE  VARIABLE  NAMED 

AAAA 

1383 

11E2 

REN 

•CK.5000S' 

AAAA 

1303 

11E2 

REN 

AAA* 

IN  THE  FORMAT  "YYHMDD" 

AAAA 

1333 

11E2 

REM 

AA** 

AAAA 

RACP200 
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13B3 

11E2 

REH 

OUTPUT  : 

•RT.SOOO*  IS  THE  RETURN  CODE 

13B3 

11E2 

REM 

«*«« 

VARIABLE.  IF  THIS  VARIABLE 

•*** 

13B3 

11E2 

REM 

CONTAINS  ANY  NUMBER  OTHER 

»**« 

1383 

11E2 

REM 

•*** 

THAN  0,  AN  ERROR  UAS  FOUND 

1383 

11E2 

REM 

IN  THE  DATE. 

1383 

11E2 

REM 

1383 

11E2 

REM 

*«•« 

RESERVED  LINE 

*•** 

1383 

11E2 

REM 

NUMBERS  :  5001-5009 

**•* 

1383 

11E2 

REM 

*«•**•*««•«*«•«««•«•«*«*•»««***«*««««•*«*«***«•«•«••*«******»****** 

1383 

11E2 

RT.5000  >  0 

13BA 

11E2 

CKTEAR  >  VAL(LEFTS(CK. 50008,2))  ‘YEAR  NUMERIC  VALUE 

UCO 

11E4 

CKMONTH  3  VAL(MIOS<CK. 50008,3, 2))  ‘HOMTM  NUMERIC  VALUE 

13E3 

11E6 

CKOAY  >  VAL(RIGHT8(CK. 50008,2))  ‘DAY  NUMERIC  VALUE 

13F6 

11E8 

13F6 

11E8 

IF  CKMONTH  <  1  THEN  RT. 5000^1  : 

GOTO  5009 

HOC 

TIES 

IF  CKMONTH  >  12  THEN  RT.5000>1  : 

GOTO  5009 

H22 

11E8 

IF  CKDA1 

<  1  THEN  RT.S000«2  : 

GOTO  5009 

U30 

11E8 

IF  CKDAY  >  31  THEN  RT. 5000^2  : 

GOTO  5009 

144E 

HES 

1HE 

11E8 

REM 

LEAP  YEAR  CHECK 

1HE 

11E8 

N0LENCTH(2>  «  28 

U55 

11E8 

IF  CKMONTHo  2  THEN  GOTO  5005  'MUST  BE  FEBRUARY 

14M 

11E8 

IF  (CKYEAR  MOO  4)  <>  0  THEN  GOTO  5005  'MUST  BE  A  LEAP  YEAR 

U79 

11E8 

HOLENCTH(2)  >  29 

1480 

11E8 

1480 

11E8 

5005 

IF  CKDAY  >  MOLENGTHiCKMONTH)  THEN 

RT.5000«3  ;  GOTO  5009 

U9f 

ttE8 

149F 

11E8 

5009 

RETURN 

14A2 

11E8 

REN 

HA2 

11E8 

14A2 

11E8 

14A2 

11E8 

5010 

REM  SINCLUOE:  'RACSSOIO.SUB'  Include  the  NUMERIC  STRING  EDITOR 

14A3 

11E8 

REM 

A**************************** 

UA3 

11E8 

REN 

AMBULATORY  CARE  DATA  BASE 

1  NAY  85 

14A3 

HES 

REM 

SKIP  COLE 

«*** 

14A3 

11E8 

REM 

SUBROUTINE  NAME  : 

RXXSSOIO.SUB 

•**« 

14A3 

11E8 

REH 

SCANNER  PROGRAM  • 

ALL 

14A3 

11E8 

REM 

«««« 

FUNCTION 

THIS  aiSROUTINE  NODULE 

•*«* 

14A3 

11E8 

REM 

*•*« 

PERFORMS  A  NUMERIC  STRING 

14A3 

11ES 

REM 

**** 

EDIT, 

•  **« 

14A3 

11E8 

REM 

•««* 

14A3 

11EB 

REM 

*««* 

INPUT  : 

STRING  TO  BE  EDITED  IS  IN 

**** 

14A3 

11E8 

REM 

***• 

THE  VARIABLE  NAMED 

14  A3 

11E8 

REM 

«»«** 

'CK.5010S‘ 

•«*« 

14A3 

11EB 

REN 

•*«* 

14A3 

11E8 

REH 

**** 

OUTPUT 

'RT.5010‘  IS  THE  RETURN  CODE 

«*** 

14A3 

11E8 

REM 

**** 

VARIABLE.  IF  THIS  VARIABLE 

**•* 

UA3 

11E8 

REN 

CONTAINS  ANY  NUMBER  OTHER 

14A3 

11E8 

REH 

**«• 

THAN  0,  AN  ERROR  UAS  FOUND 

«*•* 

14  A3 

11E8 

REM 

IN  THE  STRING. 

**«* 

14A3 

11E8 

REN 

14A3 

11E8 

REH 

RESERVED  LINE 

14  A3 

11E8 

REH 

NUMBERS  :  5011-5019 

***• 

RACt>200 
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UA3 

11E8 

REM 

«««*«*■ 

**«*««•*««**«***«**«**«•*«««*•*•••«•««*****•**•*•**••*•* 

1AA3 

11E8 

RT.5010  «  0 

UAA 

11E8 

UAA 

11E8 

FOR  15010  >  1  TO  LENTCK.SOIOS) 

1ABA 

11EA 

J5010>  ASC(M1D8<CK.5010S, 15010,1)) 

HCE 

ItEE 

IF 

J5010  <  48  OR  J5010  >  57  THEN  RT.5010  >  RT.5010  +  1 

UF6 

11EE 

NEXT  15010 

1507 

11EE 

1507 

11EE 

RETURN 

150A 

11EE 

nbn 

150A 

11EE 

150A 

11EE 

7000 

REM  SINCLUDE:  'RACSTOOO.SUB'  Include  the  SCREEN  HEADER  SUB 

1508 

11EE 

REM 

***«***»******I»*«****M**«««***«*«««**«*«**««*««**««*****«****«***« 

1508 

11EE 

REM 

AMBULATORY  CARE  DATA  BASE  13  APR  85 

**** 

1508 

11EE 

REM 

SKIP  COLE 

**** 

1508 

11EE 

REM 

•*** 

SUBROUTINE  NAME  :  RACSTOOO.SUB 

***« 

1508 

11EE 

REM 

**«* 

SCANNER  PROGRAM  «  :  ALL 

1508 

11EE 

REM 

«*«* 

FUNCTION  :  THIS  SUBROUTINE  MODULE 

**** 

1508 

11EE 

REM 

**** 

PRINTS  THE  STANDARD  SCREEN 

1508 

11EE 

REM 

HEADING. 

1508 

11EE 

REN 

•••• 

INPUT  :  COMMON  VARIABLE  USERS(2) 

1508 

11EE 

REM 

*««« 

SYSTEM  DATE 

1508 

11EE 

REM 

•««« 

1508 

11EE 

REM 

•««« 

OUTPUT  :  SCREEN  HEADING 

1508 

11EE 

REN 

•««* 

1508 

11EE 

REM 

**«« 

RESERVED  LINE 

*«*« 

1508 

11EE 

REM 

NUMBERS  ;  7001-7010 

1508 

11EE 

REM 

1508 

11EE 

1508 

11EE 

7001 

LOCATE 

t.1 

1515 

11EE 

PRINT  "U.S.  ARMY  AMBULATORY  CARE  INFORMATION  SYSTEM" 

1510 

11EE 

LOCATE 

1,65 

152A 

11EE 

PRINT  DATES; 

1532 

11EE 

LOCATE 

2.1 

153F 

11EE 

PRINT  "USER  :  ";USERS<1) 

154C 

11EE 

RETURN 

154F 

11EE 

7100 

REN  SINCLUDE:  'RACS7100.SU8*  Include  the  PRINTER  HEADER  SUB 

1550 

11EE 

REM 

1550 

11EE 

REM 

AMBULATORY  CARE  DATA  BASE  13  APR  85 

«•** 

1550 

11EE 

REM 

SKIP  COLE 

1550 

11EE 

REM 

**«* 

SUBROUTINE  NAME  :  RXXS7100.SUB 

1550 

11EE 

REM 

**•« 

SCANNER  PROGRAM  «  :  ALL 

«*«« 

1550 

11EE 

REM 

FUNCTION  :  THIS  SUBROUTINE  NODULE 

1550 

11EE 

REN 

**** 

PRINTS  THE  STANDARD  HEADING 

««•* 

1550 

11EE 

REM 

**** 

ON  THE  PRINTER. 

1550 

11EE 

REM 

INPUT  DATE.PACE,PGMIDS,PGMTITLS 

1550 

11EE 

REM 

*«** 

'550 

11EE 

REM 

OUTPUT  :  PRINTER  HEADING,  LN. COUNT 

1550 

11EE 

REH 

1550 

11EE 

REM 

♦««« 

RESERVED  LINE 

1550 

11EE 

REM 

NUMBERS  :  7101-7110 

1550 

11EE 

REH 

»***« 

1550 

11EE 

1550 

llEE 

7101 

IF  PAGE 

>  0  T  'N  KRINT  r':;,»(12); 
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Offset 

Data 

Source  Line 

IBM  Personal  Conputer  BASIC  Compiler  VI. C) 

1566 

11EE 

LPRINT  “ARMY  AMBULATORY  CARE  INFORMATION  SYSTEM _  “;PGMT1TL$; 

1573 

tIEE 

LPRINT  TAB<70), -OATES 

1586 

11EE 

PAGE“PAGE+1 

1S8E 

11EE 

LPRINT  "PROGRAM  “;PGMI0S;TAB(70);"PAG£"; 

15A8 

11EE 

LPRINT  USING  “««II#“;PAGE 

1587 

11EE 

LPRINT 

15BF 

11EE 

LN.CQUNT>3 

15C6 

11EE 

RETURN 

15C9 

11EE 

15C9 

11EE 

8000 

REM  SINCLUOE:  •RACS8000.SUB'  Include  the  DECODE  SUB  CROUP 

15CA 

11EE 

REM 

•*** 

15CA 

11EE 

REM 

**** 

AMBULATORY  CARE  DATA  BASE  13  APR  85 

**• 

15CA 

11EE 

REM 

SKIP  COLE 

**• 

1SCA 

11EE 

REM 

SUBROUTINE  NAME  :  RXXSSOOO.aJB 

**• 

15CA 

11EE 

REM 

«««« 

SCANNER  PROGRAM  «  i  ALL 

15CA 

11EE 

REN 

**•* 

FUNCTION  :  THIS  SUBROUTINE  MODULE 

15CA 

11EE 

REM 

IS  A  GROUPING  that  PERFORMS 

15CA 

11EE 

REM 

•••« 

VARIOUS  DECODING  FUNCTIONS 

*** 

15CA 

11EE 

REM 

ON  THE  SCANNER  DATA 

*•* 

15CA 

11EE 

REM 

*•* 

15CA 

11EE 

REM 

8001  -  DECODE  THE  HEADER  POSITIONS  (POINTER  0-20) 

15CA 

11EE 

REM 

8050  •  CHECK  FOR  END  OF  JOB 

15CA 

11EE 

REN 

8100  -  PRINT  THE  HEADER  DATA  ON  THE  SCREEN 

15CA 

11EE 

REM 

8200  -  DECODE  THE  RESPONSE  POSITIONS  (POINTER  21-..; 

•Hit 

15CA 

11EE 

REM 

(RETURNED  IN  TEXTS  STRING  VARIABLE) 

#** 

15CA 

11EE 

REN 

*•* 

15CA 

11EE 

REM 

•««« 

INPUT  :  SHEET  RECORD,  RECORD  LENGTH 

15CA 

11EE 

REM 

•««« 

15CA 

11EE 

REM 

•  *«« 

OUTPUT  :  'TEXTS’  TRING  VARIABLE 

15CA 

11EE 

REM 

15CA 

11EE 

REM 

RESERVED  LINE 

15CA 

11EE 

REN 

NUMBERS  :  8001-8500 

•** 

15CA 

11EE 

REN 

15CA 

11EE 

15CA 

11EE 

•OECOOE  THE 

HEADER  ONLY 

ISCA 

1IEE 

8001 

POINTER  “  0 

1501 

11F0 

RECOROPTR  >  VARPTR($HEETREC(0)} 

1508 

11F2 

FOR  J8000  «  1  TO  21 

150F 

11F2 

8002 

TEXTS*  TEXT$*CHRS(PEEK(RECOROPTR  ♦  POINTER)) 

15F0 

11F2 

P0INTER=P0IMTER+1 

1605 

11F2 

NEXT  J8000 

16U 

11F4 

PROGRAMS*  LEFTS(TEXTS,3) 

1623 

11F8 

BATCHS*  MIDS(TEXTS,4,3) 

1635 

11FC 

SERIALS*  HI0S(TEXTS,7,4) 

1647 

1200 

RUNIDS*  HIDS(TEXTS,11,1) 

1659 

1204 

FORMS*  MIDS(TEXT$,12,2) 

1668 

1208 

POCKETS*  MIDS(TEXTS,14,1) 

1670 

120C 

SCANERR1S*MIDS(TEXTS, 16,2) 

168F 

1210 

SCANERR2S*M I 0S( TEXTS , 18 , 2 ) 

16A1 

1214 

SCANERR3S*MIDS( TEXTS, 20 , 2 ) 

1683 

1218 

GOTO  8500 

1687 

1218 

1687 

1218 

8050 

REM  CHECK  FOR  END  OF  JOB/END  OF  BATCH 

1688 

1218 

IF  PROGRAMS  *  PCMIDS  THEN  GOTO  8500 

RACPZOO 

PATIENT  OESTRING/DECGOE  PROGRAM 
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OffMt 

Data 

Source  line 

IBM  Personal  ccanputer  HASIC  Fcjniii trr  VI. 00 

16CA 

1218 

IPRINT  $TRINGS(80,«*«} 

1608 

1218 

LPRINT 

16E0 

1218 

LPRINT  "RECORDS  PROCESSED  ...  ".-SERIALS 

16ED 

1218 

LPRINT  "STARTED  AT  .  ".-BTIMES 

16FA 

1218 

LPRINT  "ENDED  AT  . ■;TI(«$ 

1707 

1218 

LPRINT  CHgSdZ) 

1712 

1218 

GOTO  30000 

1716 

1218 

1716 

1218 

8070 

REM  CHECK  FOR  SCANNER  ERRORS 

1717 

1218 

IF  POCKETS  a  "  “  GOTO  8500 

1729 

1218 

LPRINT  LITHOS; 

1731 

1218 

LPRINT  "  ...  SCANNER  ERRORS  :  "; 

1739 

1218 

LPRINT  SCANERR1S;"  / 

17G6 

1218 

LPRINT  SCANERR2S;"  / 

1753 

1218 

LPRINT  SCANERR3S 

175B 

1218 

LN*LN*1 

1763 

121A 

GOTO  999 

1767 

121A 

1767 

121A 

8100 

REM  PRINT  THE  HEADER  VARIABLES  OH  THE  TUBE.... 

1768 

121A 

LOCATE  5,1: PR I NT  "PROGRAM  "; PROGRAMS; 

1782 

121A 

1782 

121A 

PRINT  "  BATCH  ";BATCHS; 

178F 

121A 

PRINT  "  RUN  ";RUNIDS; 

179C 

121A 

PRINT  «  FORM  «; FORMS; 

17A9 

121A 

PRINT  "  POCKET  "; POCKETS 

17B6 

121A 

GOTO  8500 

17BA 

121A 

17BA 

121A 

8200 

REH  DECODE  THE  RESPONSE  POSITIONS 

17BB 

121A 

POINTER  a  21 

17r2 

121A 

RECOROPTR  a  VARPTR(SHEETREC(0)} 

17C9 

121A 

FOR  J8000  a  22  TO  RECOROLENGTN 

17D6 

121C 

8202 

TEXTS  a  TEXT$+CHRS(PEEK(RECORDPTR  ♦  POINTER)) 

UFA 

1210 

POlNTERaPOINTER+1 

17FC 

1210 

NEXT  JBOOO 

1800 

1210 

1800 

1210 

8500 

RETURN 

1310 

1210 

1810 

1210 

REM . END  OF  RXXS8000.SUB  . 

1810 

1210 

1810 

1210 

9000 

REM  S INCLUDE:  'RACSPOOO.SUB*  INCLUDE  THE  SCANNER  CONTROL  SUB 

1811 

1210 

REH 

1811 

1210 

REM 

*•••  AMBULATORY  CARE  DATA  BASE  13  APR  85 

*«*• 

1C11 

1210 

REM 

SKIP  COLE 

1811 

1210 

REM 

*•••  PROGRAM  NAME  :  RACS9000.SUB 

1811 

1210 

REM 

••••  SCANNER  PROGRAM  #  :  ALL 

1811 

1210 

REM 

*•••  FUNCTION  :  THIS  SUBROUTINE  MODULE 

**«« 

1811 

1210 

REM 

CONTROLS  THE  SCAMMER  I/O 

**** 

1811 

1210 

REM 

***« 

*«** 

:811 

1210 

REM 

•••*  INPIJT/OUTPUT  :  REFER  TO  THE  ASYNCHRONOUS 

*«** 

1811 

1210 

REM 

**•*  COMMUNICATIONS  MANUAL  AND  THE 

**** 

1811 

1210 

REM 

••••  PRE-RELEASEO  SOFTWARE  GUIDE 

**** 

1811 

1210 

REM 

«««* 

**«« 

121C 

kbH 

1811 

1210 

REM 

••**  RESERVED  LINE 

HACP200  PAGE  19 
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1811 

121C 

REN 

••••  NUMBERS  :  9001-9100 

•  *«* 

1811 

121C 

REM 

******•****••*••••»*•••**«*••«•**«*•******«*««««*••••**•««*«•****** 

1811 

121C 

1811 

121C 

1811 

121C 

REM 

1811 

121C 

REM 

**•*  SUBROUTINE  9001  -  PROTOCOL  SETUP  FOR  SCANNER 

1811 

121C 

REM 

•••*  ARGUMENTS:  PRESET  ...  SEE  BELOU 

1811 

121C 

REM 

1811 

121C 

9001 

REM 

1812 

121C 

PROTOCOL(O)  =  9600  'BAUD  RATE 

1819 

121C 

PROTOCQL(I)  3  78  'PARITT  (SEE  PAGE  4-8  OF  MANUAL) 

1820 

121C 

PROTOCOL(2)  >  a  ‘DATA  BITS 

1827 

121C 

PROTKOLO)  ■  1  'STOP  BITS 

182E 

121C 

PR0T0C0L(4)  «  2  ■RS-232  PORT 

1835 

121C 

PROTOCOL (5)  «  0  'WRITE  TIME-OUT 

183C 

121C 

PR0T0C0L(6)  >  0  'READ  TIME-OUT 

1843 

121C 

1843 

121C 

ERRSTATS  >  SPACE$(60) 

184F 

121C 

ARGPTR  *  VARPTR(PROIOCOL{0)) 

1856 

121E 

CALL  SETUP  (ARGPTR, ERRSTATS) 

1867 

1216 

ERRMSGS*"" 

1870 

1216 

IF  ASCtERRSTATS)  <>  64  THEN  ERRMSG$«"S6TUP  ERROR  •♦ERRSTATS 

188C 

1216 

GOTO  9100 

1890 

1216 

1890 

1216 

REM 

1890 

121E 

REM 

•**•  SUBROUTINE  9010  -  CONTROL  OPTIONS  FOR  SCANNER 

1890 

121E 

REM 

••••  ARGUMENTS:  CNTRLOPT 

1890 

121E 

REN 

CNTRLOPT  =  1  =  START  SCANNER  (SI) 

1890 

121E 

REM 

••••  CNTRLOPT  »  2  =  STOP  SCANNER  (SO) 

1890 

121E 

REM 

*•••  CNTRLOPT  »  3  =  TERMINATE  COMMUNICATIONS  TO  SCANNER  (0C3) 

1890 

121E 

REM 

*•**  CNTRLOPT  »  4  =  CLEAR  TRANSPORT  PATH  (DC2) 

1890 

121E 

REM 

•••»  CNTRLOPT  *  5  *  SELECT  PRIMARY  STACKER  "31" 

1890 

1216 

REM 

••••  CNTRLOPT  *  6  =  SELECT  SECONDARY  STACKER  "32" 

1890 

1216 

REM 

***•  CNTRLOPT  *  7  =  POSITIVE  RESPONSE/SELECT  SCANNER  (DC1 ) 

1890 

1216 

REM 

*•**  CNTRLOPT  *  8  =  REQUEST  STATUS  (ESC) 

1890 

121E 

REM 

1890 

1216 

9010 

REN 

1891 

121E 

ERRSTATS  >  SPACEt(60) 

1890 

121E 

CALL  CNTROL  (CNTRLOPT .ERRSTATS) 

18AE 

121E 

ERRMSGS="" 

18B7 

1216 

IF  ASC(ERRSTATS)  <>  64  THEN  ERRMSGS:''CONTROL  ERROR  "♦ERRSTATS 

1803 

1216 

GOTO  9100 

1807 

1216 

1807 

1216 

REM 

1807 

1216 

REM 

SUBROUTINE  9020  -  SCAN  SHEET  CALL 

1807 

1216 

REM 

«««* 

1807 

121E 

REM 

ARGUMENTS:  REAOTYPE 

1807 

1216 

REM 

REAOTYPE  »  2  »  REQUEST  NEW  DOCUMENT  FROM  SCANNER 

1807 

1216 

REM 

••••  REAOTYPE  »  3  »  RETRANSMIT  CURRENT  DOCUMENT 

1807 

1216 

REM 

1807 

1216 

REM 

*•••  ARGUMENTS:  RECOROLENGTH 

1807 

1216 

REM 

**•*  NUMERIC  VARIABLE  SET  TO  THE  NUMBER  OF  CHARACTERS  TO  BE 

1807 

1216 

REN 

TRANSMITTED 

1807 

1216 

REM 

RACP200 
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Offset 

Oeta 

Source  Line  IBM 

1807 

121E 

9020 

REM 

1808 

121E 

ERRSTATS  >  SPACE$(60} 

18E4 

121E 

RECORDPTR  «  VARPTR(SHEETREC(0)) 

1BEI 

121E 

CALL  SCAN  (REAOTYPE.RECOROLENGTH.RECORDPTR.ERRSTATS) 

1904 

121E 

ERRMSGSx"* 

1900 

121E 

IF  H1DS(ERRSTAT$,14,3)  >  ■‘415'*  THEN  ERRMSGS:»*E5C” 

192E 

121E 

GOTO  9100 

1932 

121E 

1932 

121E 

REM 

1932 

121E 

REM 

*•••  SUBROUTINE  9030  -  TRANSPORT  PRINT  CALL  •••** 

1932 

121E 

REN 

***• 

1932 

121E 

REM 

*•••  ARGUMENTS:  PRINTPOS  **•*• 

1932 

121E 

REM 

NUMERIC  VARIABLE  INDICATING  THE  STARTING  PRINT  POSITIOM  *»•*• 

1932 

121E 

REM 

VALUES  «  0  THRU  90  •••** 

1932 

121E 

REM 

**««  »«•*• 

1932 

121E 

REN 

ARGUMENTS:  PSTRINCS 

1932 

121E 

REM 

TEXT  TO  BE  PRIHTEO  ON  THE  FORM 

1932 

121E 

REN 

***«« 

1932 

121E 

REM 

NOTE:  THIS  ROUTINE  HAS  NO  EFFECT  UNLESS  THE  SCAN  ••••• 

1932 

121E 

REM 

HEADER  SHEET  IS  MARXEO  'PRINTER  ON'  ••••• 

1932 

121E 

REM 

*•*•**•«*«•*•****«•*«*•••*«**♦««**«****«*•*«*••**«*«****•«•*«**•*•• 

1932 

121E 

9030 

REM 

1933 

121E 

ERRSTATS  >  SPACE$(60) 

193F 

121E 

RECORDPTR  >  VARPTR($NEETREC(0}) 

1946 

121E 

CALL  TPR I  NT (PR I NTPOS , PSTR 1 NGS, ERRSTATS) 

1958 

1224 

IF  ASC( ERRSTATS)  <>  64  THEN  ERRMSGS:"PRINT  ERROR  "-'^ERRSTATS 

1977 

1224 

GOTO  9100 

1978 

1224 

1978 

1224 

9100 

RETURN 

ftCM 

197E 

1224 

197E 

1224 

REM 

END  OF  SUBROUTINES 

197E 

1224 

197E 

1224 

25000 

REM  USER  TERMINATED  INPUT...  FILE  IS  NOT  TO  BE  USEOIIII! 

197F 

1224 

LPRINT  •VSER  TERMINATED  INPUT  ..  DATA  WILL  NOT  BE  USED!" 

1987 

1224 

LPRIHT  "ERASING  FILE  "lOATFILS 

1994 

1224 

BEEP 

1998 

1224 

CLS  :  PRINT  "USER  TERNINOATED  INPUT  ..  DATA  WILL  NOT  BE  USED!” 

19A4 

1224 

CLOSE 

19Aa 

1224 

OPEN  OAT FILS  FOR  OUTPUT  AS  #1 

19BA 

1224 

PRINT  l»1,STRINC$<R£COROLEMGTH,"X")  'VOID  THE  FIRST  RECORD 

19CC 

1224 

CLOSE 

1900 

1224 

1900 

1224 

30000 

REM 

1901 

1224 

CLOSE 

1905 

1224 

OPEN  "0",1, "RACB00.BAT" 

19E7 

1224 

PRINT  #1, "RECOUP  RACPTSRT.BAT" 

19F2 

1224 

PRINT  #1,"RACB10" 

19F0 

1224 

CLOSE 

1A01 

1224 

END 

1'05 

1224 

1A08 

1224 

RACP200 
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IBM  Personal  Coinputer  BASIC  Compiler  VI. On 


22151  Bytes  Available 
14541  Bytes  Free 


0  Warning  Error(s) 
0  Severe  Errorls) 


PACE  1 
06-C8-87 
07:ZS:4S 


Offset 

Data 

Source  Line 

IBM  Personal  Computer  BAKU:  Compiler  VI. 00 

001A 

0002 

REM  SLINESIZE:  132 

001A 

0002 

REM  SPAGESIZE:  66 

001A 

0002 

REM  STITLE:  'RACPSOO  ' 

001A 

0002 

REM  SSUBTITLE:  'PROVIDER  DESTRING/DECGOE  PROGRAM' 

001A 

0002 

REM  SPACE 

f 


RACPSOO 

PROVIDER  OESTRING/DECCOE  PROGRAM 


Offset 

Data 

001A 

0002 

001A 

0002 

001A 

0002 

001A 

0002 

001A 

0002 

001A 

0002 

oaiA 

0002 

001A 

0002 

001A 

0002 

001A 

0002 

001A 

0002 

001A 

0002 

001A 

0002 

001A 

0002 

001A 

0002 

001A 

0002 

001A 

0002 

001A 

0002 

001A 

0002 

001 A 

0002 

001A 

0002 

001A 

0002 

001 A 

0002 

001A 

0002 

Q01A 

0002 

001A 

0002 

001A 

0002 

001A 

0002 

001A 

0002 

001A 

0002 

001A 

0002 

001A 

0002 

001A 

0002 

001A 

0002 

001A 

0002 

001A 

0002 

001A 

0002 

001A 

0002 

001A 

0002 

001A 

0002 

001A 

0002 

001A 

0002 

001A 

0002 

001A 

0002 

001A 

0002 

001A 

0002 

001A 

0002 

001A 

0002 

001A 

0002 

001A 

0002 

001A 

0002 

001A 

0002 

001A 

0002 

001A 

0002 

PAGE  2 
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Source  Line  IBM  Personal  Conputer  BASIC  Compiler  V1.0C 

REM  . . . 

REM  I  NAME:  RXXP300  AMBULATORY  CARE  INFORMATION  SYSTEM  | 

REM  I  Date:  28  Feb  84  PROVIDER  REGISTRATION  PROGRAM  | 

REM  I  Floyd  Cole  I 

REM  I  a  JUN  87  CHANGE  NAMES  FOR  NEU  SYSTEM  ORB  | 

REM  . . . 

REM  PROVIDER  OMR  INPUT  PROGRAM 

REH 

REM  This  program  reads  the  provider  OMR  data,  converts  various 
REM  fields,  prints  an  error  report  and  produces  the  file: 

REM 

REN  PROVIDER.DAT 

REM 

REM  for  input  to  FOCUS.  NOTE  THAT  THIS  FILE  IS  OPENED  FOR  APPEND 
REH  each  time  the  program  is  run.  Thus,  if  the  file  does  not  exist, 

REM  records  will  be  added  to  the  front.  If  the  file  exists,  records 
REN  will  be  added  to  the  end  of  the  current  file.  It  is  intended  that 
REM  the  FOCUS  DIALOGUE  MANAGER  ROUTINE  which  toads  the  data  will  delete 
REH  the  data  file  after  the  load  has  been  successfully  accomplished. 

REM 

REM 

REM  If  there  is  no  valid  user  logged  at  the  time  of  execution,  this 
REH  program  will  chain  to  the  logon  program  RXXPOS,  otherwise, 

REM  the  program  chains  to  program  RXXP10  on  exit. 

REH  SINCLUOE:  •RACDIM.HOD'  REM  Include  the  DIMENSION  DEFINITIONS 

t*****************************************************^**************** 

'•  NAME:  RACOIM.MOO  DIMENSION  DEFINITIONS  * 

'•  Date:  28  Feb  84  Written  by:  Floyd  Cole  • 


Dimensioned  variables  are  defined  in  this  file. 

It  is  an  included  file  so  it  cannot  be  run  in  a  stand-alone, 
mode. 

This  program  segment  may  be  modified,  but  all  files  containing 
an  include  for  this  segment  must  be  re-compiled  in  order  to 
affect  the  changes  made  here. 

***••*•*•••<  start  of  dimension  DEFINITION  •*•••••••••••••••••' 


OEFINT  A-Z 

DIM  USERSC 2 ) , HOLENGT N ( 1 2 ) , DATEERRSl 3 ) 

*••****•***•  SMQ  Qf  dimension  definitions 


REM  DIMENSION  STATEMENTS  UNIQUE  TO  THIS  PROGRAM 


DIM  SHEETRECCITSO) 
DIM  PROTOCOL(7) 

DIM  ADCATS(3) 

DIM  YNS(3) 

DIM  E0.HSGS(30) 


'(MAX.  SIZE  FOR  A  SHEET  FROM  THE  SCANNER) 
■(ARRAY  FOR  SERIAL  BOARD  SETUP  PARAMETERS) 
'(DECODE  FOR  ACTIVE  DUTY  CATEGORY) 

■(YES/NO  ANSWERS  0=?,  1  *  Y  ,  2=N  ,  3=X) 
■(ERROR  MESSAGES  FROM  EDIT  ROUTINES) 


REM  I INCLUDE:  'RACCMN.MOO'  REM  Include  the  COMMON  AREA  DEFINITION 


RACPSOO 

PROVIDER  DESTRIHG/DECOOE  PROGRAM 


OffMt  Data  Source  Line 
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NAME:  RACOW.MOO  COMMON  AREA  DEFINITION  * 

Date:  28  Feb  84  Written  by:  Floyd  Cole  * 

COMMON  AREA  DEFINITIONS  WILL  BE  HELD  IN  THIS  FILE.  IT  IS  AN 
INCLUDED  FILE  SO  IT  CAHNOT  BE  RUM  IN  A  STAND*ALONE,  MODE. 

This  program  segment  my  be  modified,  but  all  files  containing 
an  include  for  this  segment  must  be  re*coapiled  in  order  to 
effect  the  changes  made  here. 


•••START  Of  COMMON  oeFINITIONS"^***^*^^^^^^^^^^^^^^^^ 


COMMON  FORE, BACK, BOARD, HIDE, EFORE.EBACK.BELLS  'BASIC  SCREEN  COLORS 


COMMON  HEADERS 


•21  CHARACTER  SCANNER  HEADER  INFO 
COMMON  TEXTS  "  AIMING  CHARACTERS  FROM  SCANNER 

COMMON  PGMIDS  'PROGRAM  OR  FORM  ID 

COMMON  MOLENGTHO  'OATS  IN  THE  MONTH 

COMMON  USERSO 

•••••••••••••END  Of  COMMON  0EFINITION»«^^*^^^^^^^^^^^^^^^^^^^ 


REM  SINCLUDE:  'RACOEF.HOD'  REM  Include  the  DEFAULT  DEFINITIONS 

I  **•«•***««*««***«*««*•*«***********«»*•*••*•***««*******«**••******* 


NAME:  RACPOI.DEF  DEFAULT  DEFINITIONS  • 

Date:  28  Feb  84  Written  by:  Floyd  Cole  • 

a****************************************************************** 

Variables  used  in  common  that  have  a  default  value  on  start-up 
will  be  held  in  this  file.  It  is  an  included  file  so  it  cannot 
be  run  in  a  stand*alone  mode.  In  normal  operation,  this  file 
should  be  'included'  in  the  main  program  only  (RACPIO.BAS). 

This  program  segment  may  be  modified,  but  all  files  containing 
an  include  for  this  segment  must  be  re^compiled  in  order  to 
affect  the  changes  made  here. 


•START  OF  DEFAULT  DEFINITION^ 


001A 

0002 

FORE  =  15 

•FOREGROUND  COLOR 

0042 

0E6C 

BACK  =  1 

'Background  Color  ' 

0049 

0E6C 

BORO  »  4 

■BORDER 

0050 

0E6E 

HIDE  >  4 

•ALTERNATE  COLOR 

0057 

0E6E 

EFORE"  14 

■ERROR 

FOREGROUND  1 

OOSE 

0E6E 

EBACK:  0 

•ERROR  BACKGROUND  1 

0065 

0E6E 

BELLS  -  CHRS(7) 

'Sound 

the  bell 

0071 

0E6E 

0071 

0E6E 

HOLENGTH(I) 

= 

31 

•JAN 

r078 

0E6E 

MOLENGTH(2) 

a 

23 

■FEB  <--l 

007F 

0E6E 

MOLENGTH(3) 

8 

31 

■MAR 

0086 

0E6E 

NOLENGTHU) 

a 

30 

■APR 

0080 

0E6E 

HOLENGTH(5) 

a 

31 

■MAT 

0094 

0E6E 

MOLENGTH(6> 

a 

30 

■JUN 

r098 

0E6E 

MOLENGTH(7) 

= 

31 

•JUL 

00A2 

0E6E 

HOLENGTH{8) 

= 

31 

■AUG 

■FEB  <--MOOIFIEO  IN  SUBROUTINE  RACS5000.SUB 


i 


RACP300 

PACE  4 

PROVIDER  DESTRING/DECOOE  PROGRAM 

06-08-87 

07:28:45 

Offset 

Date 

Source  Line 

IBM  Personal  Coaputer  BASIC  Conpiler  VI. 30 

OOA9 

0E6E 

H0LENGTH<9)  ■  30  'SEP 

OOBO 

0E6E 

HOLENGTH(IO)  «  31  <007 

0087 

0E6E 

HOLENGTHdl)  >  30  'NOV 

OOBE 

0E6E 

H0LENGTH(12)  ■  31  'OEC 

oocs 

0E6E 

oocs 

0E6E 

DATEERRS(O)  s  « 

OOCE 

0E6E 

DATEERRSd)  ■  "INVALID  MONTH" 

0007 

0E6E 

DATEERR$(2)  «  "INVALID  DAY  " 

OOEO 

0E6E 

DATEERR$(3)  X  "DAY  TOO  LARGE  FOR  MONTH  CODED" 

OOE9 

0E6E 

OOE9 

0E6E 

MAXLENGTH  >  80  'MAXIMUM  LENGTH  OF  OUTPUT  RECORD 

OOFO 

0E70 

PADS  >  'PAD  CHARACTER  FOR  SHORT  RECORDS 

OOF9 

0E74 

OOF9 

0E74 

00F9 

0E74 

00F9 

0E74 

00F9 

0E74 

KEY  OFF 

OOFF 

0E74 

OOFF 

0E74 

P£P[|  ***•*•*****»****•**•*»*****•*•**«***•««*«***««•**•»*«««*•**«*«• 

OOFF 

0E74 

REM  THE  FOLLOWING  VARIABLES  ARE  UNIQUE  TO  EACH  PROGRAM  AND  MUST 

OOFF 

0E74 

REM  BE  CHANGED. 

OOFF 

0E74 

OOFF 

0E74 

PGMTITLS  «  "PROVIDER  REGISTRATION" 

0108 

0E78 

0108 

0E78 

PGMIDS  "  «300«  'VALUE  RECEIVED  FROM  THE  SCANNER 

0111 

0E78 

'IN  HEADER  VARIABLE  'PROGRAMS' 

0111 

0E78 

0111 

0E78 

DATFILS  »  "PROVIDER.OAT"  'FILE  TO  BE  INPUT  TO  FOCUS 

011A 

0E7C 

01 1A 

0E7C 

REM  LENGTH  OF  STRING  RECEIVED  FROM  THE  OMR.... 

011A 

0E7C 

HEADER  X  21 

0121 

0E7E 

RESPONSE"  88 

0128 

0E80 

RECORDLENGTN  "  HEADER  *  RESPONSE 

0133 

0E82 

0133 

0E82 

0133 

0E82 

0133 

0E82 

BTIMESxTIMES  'SCAN  START  TIME 

013C 

0E86 

013C 

0E86 

REM  ARMY  ACTIVE  DUTY  TABLE 

0130 

0EB6 

ADCATS(0)="  " 

OHS 

0E86 

ADCATSd)="E" 

OUE 

0E86 

ADCATS(2)="0" 

0)57 

0E86 

ADCATS(3)»"U" 

0160 

0E86 

0160 

0686 

REM  YES/NO  TABLE 

0160 

0E86 

YNS(O)""?"  :  YNSd)="Y"  :  YNS{2)«"N"  :  YNS(3)x"X" 

0184 

0E86 

0184 

0E86 

REM  SPACE 

i 


I 


L 


RACP3Q0 

PROVIDER  DESTRING/OECCOE  PROGRAM 


Offstt 

0184 
0189 
0180 
0192 
0192 
0192 
0192 
0192 
0192 
01A4 
01A4 
01A4 
01A4 
01A4 
01AF 
01 B9 
01C5 
01 CC 
01E1 
01 F7 
OIFT 
Q1F7 
01 F7 
01F7 
01F7 
01FC 
0216 
0216 
0216 
0222 
023C 
023C 
0251 
0258 
0258 
0258 
0258 
0258 
0258 
0258 
0259 
0259 
C262 
U278 
0278 
0270 
0299 
0299 
02A2 
02A7 
02AC 
O’BI 
02C3 
02C8 


Data  Source  Line 


PAGE  5 
06-08-87 
07:28:45 

IBM  Personal  Computer  BASIC  Coijpiler  VI. 00 


0E86 

0E86 

0E86 

0E86 

0E86 

0E86 

0E86 

0E86 

0E86 

0E86 

0E86 

0E86 

0E86 

0E86 

0E86 

0E86 

OESa 

0E8a 

0E8S 

0E8a 

0E88 

0E88 

0E88 

0E83 

0E88 

0E68 

0E8C 

OEBC 

0E8C 

0E8E 

0E8E 

0E8E 

0E8E 

0E9O 

0E9O 

0E90 

0E90 

0E90 

0E90 

0E9O 

0E9O 

0E90 

0E94 

0E94 

0E94 

0E94 

0E98 

0E98 

0E98 

0E98 

0E98 

0698 

0E9C 

0E9C 


OOSUB  1000  >HAKE  sure  they  are  LOGGED  OH 

CLS 

GOSUB  7000  ‘PRINT  SCREEN  HEADING 


REM 

REM 

REN 

REM 


****  OPEN  FILE  TO  CONTAIN  SCANNED  DATA 


OPEN  OATFILS  FOR  APPEND  AS  «1 


REM 

REN 

REM 


CLEAR  AND  DISPLAY  PROGRAM  SCREEN 

LPRINT  CHRS(IS); 

WIDTH  '■LPT1:",160 

PAGE  >  0  :  GOSUB  7100  ‘LINE  PRINTER  HEADING 
COLOR  14 

LOCATE  11,26  :  PRINT  "PROVIDER  REGISTRATION  FORM" 
COLOR  FORE,BACK,BORO 


REM  *•**•*•••••*•••••••••••«•••••••••*••*•****»***»*•*•***•*••*••»»*•*« 

REM  **•*  COMMUNICATIONS  SETUP 

REM  •••••*•••*••»•••••«♦**•*•••*•*•»*««»*«*,*«****••««*•*•••«««*****«* 

REM  PROTOCOL 
GOSUB  9001 

IF  ERRMSGS  >  "  "  THEN  LPRINT  ERRMSGS  :  GOTO  30000 


REM  START  SCANNER  (SI) 

CNTRLOPT  at  :G0SUB  9010 

IF  ERRMSGS  >  "  "  thEH  LPRINT  ERRMSGS  ;  GOTO  30000 

LOCATE  22,25:PRIHT  "PRESS  'ESC  TO  TERMINATE  SCANNING  " 
READTYPE=3  'FIRST  TIME  IN..  SCAMMER  IS  STARTED.. 


REM 

REM 

REM 

REN 


SET  SCAN  SHEET  CALL 

********************* 


10  REM  -  RETURN  POINT  TO  READ  NEXT  SHEET 
ASa INKEYS 

IF  A$=CHR$(27)  THEN  GOTO  25000 

GOSUB  9020  'SCAM  SUBROUTINE  -  GET  A  RECORO 

IF  MI0$(ERRSTATS,14,3)="415"  THEN  GOTO  25000 

TEXTS=""  'CLEAR  THE  INPUT  AREA 

GOSUB  8000  ‘OECOOE  HEADER 

GOSUB  8050  'CHECK  FOR  END  OF  JO8/EN0  OF  BATCH 

GOSUB  8200  'OECOOE  THE  RESPONSE  POSITIONS 

LITHO$=MIDS{TEXT$,101,8) 

GOSUB  8070  'CHECK  FOR  SCANNER  ERRORS 

GOSUB  8100  'PRINT  THE  DATA  ON  THE  SCREEN 


I 


RACP300 

PROVIDER  DESTRINC/OECOOE  PROGRAM 


PACE  6 
06-08-87 
07:28:45 


OffMt 

02CO 

02CD 

Data 

0E9C 

0E9C 

Source  Line  IBM  Personal  Computer  BASIC  Coopiler  VI. 00 

REM  SINCLUDE:  'RXXHSOI .H00>  INCLUDE  THE  PROVIDER  REFORMAT/EDIT  MOO 

02C0 

Ktn 

02CO 

0E9C 

REM 

•••*  AMBULATORY  CARE  INFORMATION  SYSTEM  23  APR  85 

02CO 

0E9C 

REM 

SKIP  COLE 

02CD 

0E9C 

REM 

MODULE  NAME  RXXM301.MCO 

*«*« 

02CO 

0E9C 

REN 

****  SCANNER  PROGRAM  #  300-PROVI0ER  REGISTRATION 

SHHHB 

02CO 

0E9C 

REM 

#**• 

***« 

02CD 

0E9C 

REN 

***«  PURPOSE  :  OESTRING/OECOOE  AND  EDIT 

02CO 

0E9C 

REM 

•••*  THE  OMR  STRING. 

SHHT* 

02CO 

0E9C 

REN 

**** 

tAM,  JA  i  A  A  a.  A  AAAAAAAAA  A  A 

k  * 

02CO 

0E9C 

REN 

RESERVED  LINE  NUMBERS  100-199 

*«** 

02CO 

0E9C 

REN 

•«««******««***«***«*«*'****««*««*«««*«***«««««««**************1 

k**#* 

02CO 

0E9C 

02C0 

0E9C 

N.ERR  >0  'COUNTS  THE  NUMBER  OF  ERRORS 

02D4 

0E9E 

02D4 

0E9E 

REM 

TYPE  OF  REGISTRATION 

0204 

0E9E 

100 

T0RS«MI0S(TEXTS,22,1) 

02E6 

0EA2 

02E6 

0EA2 

REM 

*•*  REGISTRATION  DATE  ••• 

02E6 

0EA2 

105 

RDATES  1  HI0S(TEXTS,23,6) 

02F8 

0EA6 

CK.SOOOS  >  RDATES 

0301 

OEAA 

CK.SOIOS  »  RDATES 

030A 

OEAE 

GOSUB  5000  'DATE  CHECK 

030F 

OEAE 

GOSUB  5010  'NUMERIC  STRING  CHECK 

0314 

OEAE 

IF  RT.SOOO  s  0  AND  RT.5010  «  0  THEN  GOTO  110 

0338 

0EB2 

N.ERR=N.ERR+1 

0340 

0EB2 

ED.MSCS(M.ERR)»"02-04  REGISTRATION  DATE  "♦OATEERRSIRT.SOOO) 

0366 

0GB2 

0366 

OEBZ 

0366 

0EB2 

REM 

LITHO  CODE  **• 

0366 

0EB2 

110 

LITHOS  »  MIOS<TEXTS, 101,8) 

0378 

0EB2 

CK.SOIOS  *  LITHOS 

0381 

0EB2 

GOSUB  5010  'NUMERIC  STRING  CHECK 

0386 

0EB2 

IF  RT.5010  »  0  THEN  GOTO  115 

0395 

0EB2 

N.ERR=N.ERR+1:  ED.MSG$<N.ERR)=''LITHO  CODE" 

0381 

0EB2 

0381 

0EB2 

REM 

**»  PROVIDERS  NAME  ••• 

0381 

0EB2 

115 

PROVLNAMES^  MIDSCTEXTS.SO, 16) 

03C3 

0EB6 

PROVFNAMES"  MID$(TEXTS,46,13) 

0305 

OEBA 

PROVHINITS=  MIDS(TEXTS,59.1) 

03E7 

OEBE 

03E7 

OEBE 

REM 

PROVIDERS  SSN  **• 

03E7 

OEBE 

120 

PROVSSNS^M I DS( TEXTS , 60 , 9) 

03F9 

0EC2 

CK.5010S  X  PROVSSNS 

0402 

0EC2 

COSUB  5010  'NUMERIC  STRING  CHECK 

0407 

0EC2 

IF  RT.5010  :  0  THEN  GOTO  125 

0416 

0EC2 

H.ERR=H.ERR+1:  ED.MSGS(M.ERR)="09  PROVIDER  SSN  " 

0432 

0EC2 

0432 

0EC2 

REN 

•••  PROVIDERS  ID 

0432 

0EC2 

125 

PROVIDS*  LEFTX(PROVLMAMES,1)  ♦  RICHTS<PROVSSHS,4) 

044  F 

0EC6 

044F 

0EC6 

REN 

***  providers  STATUS/POSITION 

RACP300 

PROVIDER  DESTRING/DECOOE  PROGRAM 


PAGE  7 
0O-08-87 
n7:;'8:45 

Offtat  Data  Sourca  Lfna  IBM  Personal  Coniputer  BASK:  Confiiler  V1.00 

044P  0EC6  130  PROVSTATS*MIOS(TEXTS,69,1) 

0481  OECA  PROVPOSNS«MIDS(TEXTS,70,2) 

0473  OECE 

0473  OECE  REH  ***  PROVIDERS  SERVICE  CODE  ***  (MAY  BE  BLANK) 

0473  OECE  135  SERVICE«VAL(M10S(TEXTS,72,1)) 

0489  OEDO 

0489  OEDO  REM  PROVIDERS  CATEGORY  CODE  **  (MUST  BE  1  -  7) 

0489  OEDO  140  CATEG>VAL(HIDS(TEXTS,29,1)) 

049F  0ED2 

049F  0ED2  REM  ***  COMPOTE  PROVIOER  COOE 

049F  0ED2  145  PROVCO-  (SERVICE*10)  ♦  CATEG 

04AE  0ED4  PROVCATS  >  RIGHTS(STRS(PROVCD>,2} 

04C1  0E08 

04C1  OEDO  REH  DECODE/CREATE/EDIT  THE  COMPOSITE  JOB  CATEGORY, GRADE  *** 

04C1  0ED8 

04C1  0ED8  ISO  IF  CATEG  <  4  THEN  GOTO  155  ELSE  GOTO  170 

0404  0ED8 

0404  OE08  155  REM  CATEGORY  >  OFF,  ENL  OR  WARRANT  (1,2,  OS  3) 

0405  OEOa  X«VAL(HIO$(TEXTS, 109,1)) 

04EB  OEDA  PAYGRADES«AOCATS(X)  ♦  MIDS(TEXT$,73,1) 

0500  OEDE  160  ON  (SERVICE+1)  GOTO  175,  162,  164,  166,  166,  168,  168,  168 

0526  OEDE  REM  ERR  ARMY  ARFC  NAVY  MRNE  CG  PHS  OTH 

0526  OEDE 

0526  OEOE  REM  ***  ARMY  FIELDS  **• 

0526  OEDE  162  JOSCOOE$=  MI0S(TEXT$,74,4)  'MOS  ♦  SSI 

0538  0EE2  IF  CATEG  <  1  OR  CATEG  >  2  THEN  JOaCOOES=JOBCXES«MIDS(TEXTS,78,2) 

0560  0EE2  IF  CATEG  >  3  THEN  JO8CXES:JOBC0OE$+MIDS(TEXTS,80,2) 

0580  0EE2  JOBCQOES  r  JOBCODE$«SPACE$( 1 )  'PAD  TO  7 

0S9C  0EE2  GOTO  180 

OSAO  0EE2 

OSAO  0EE2  REM  •••  AIR  FORCE  FIELDS 

OSAO  0EE2  164  JOBCGOES*  H1DS(TEXTS,82,7) 

0SB2  0EE2  GOTO  180 

0SB6  0EE2 

0586  OEEZ  REH  •••  NAVY/MARINE  FIELDS 

0SB6  OEEZ  166  JOBCQOES  <  HI0S(TEXTS,89,6}  *  SPACESd)  'PAD  TO  7 

0503  OEEZ  GOTO  180 

0507  OEEZ 

0507  OEEZ  REM  CG/PHS/OTHER  FIELOS  *** 

0507  OEEZ  168  JOBCOOES  s  SPACE$(7)  'PAD  TO  7 

05E3  OEEZ  GOTO  180 

05E7  OEEZ 

05E7  OEEZ  REM  CATEGORY  IS  CIVILIAN,  CONTRACT,  CONSULANT  OR  OTHER 

05E7  OEEZ  170  PAYGRAOE$«  MID$(TEXT$,99,Z) 

n5F9  OEEZ  JOBCOOE$=  MIDS(TEXT$,95,4)  ♦  SPACES(3)  'PAD  TO  7  CHAR 

u616  OEEZ  GOTO  180 

061 A  OEEZ 

061A  OEEZ  REM  ***  ERROR  PROCESSING  ROUTINE 

061A  OEEZ  175  N.ERR=N.ERR+1 

0622  OEEZ  ED.HSG$(N.ERR)="05  INVALID  COMBINATION  OF  CATEGORY  AND 

0636  OEEZ  EO.MSGJ(N.ERR)=ED.MSGS(M.ERR)+"MILITARY  BRANCH  " 

064C  OEEZ  GOTO  180 

0650  OEEZ 

0650  OEEZ  180  REM  MODULE  EXIT  POINT 


RACP30Q 

PKOVIDER  OESTRING/DECCOE  PROGRAM 


Offiet  Data 


0651 

0651 

0651 

0660 

0672 

067F 

06&B 


0EE2 

0EE2 

0EE2 

0EE2 

0EE2 

0EE4 

0EE6 


06CF 

0600 

0600 

06F6 

06F6 

070F 

070F 

0728 

0728 

0741 

0741 

074F 

0762 

0762 

0760 

0760 

0760 

0760 

0760 

076E 

076E 


Source  Line 
REM  . 


PACE  8 
06-08-87 
07;28;45 

IBM  Personal  Cosputer  SASIC  ConpHer  VI. 00 


-END  OF  MODULE  RXXM301.HOO- 


IF  N.ERR  «  0  THEN  GOTO  997 
LPRIMT  "LITHO  «  «;LITHOS;"  ...  ERRORS" 
FOR  1997  »  1  TO  N.ERR 
LPRINT  USING  "«#«  ";1997; 

LPRINT  ««>  ■;ED.MSGS(1997) 


06A1 

0EE6 

NEXT  1997 

06B2 

0EE6 

LN. COUNT  :  LN. COUNT  +  N.l 

ERR  ♦  1 

06BE 

DEES 

CNTRLOPT  >  6 

06CS 

0EE3 

GOSUa  9010 

•REJECT  THE  FORM 

06CA 

0EE8 

GOTO  998 

‘BYPASS  THE  DISK  WRITER _ 

06CE 

0EE8 

06CE 

0EE8 

997 

REH  SINCLUOE-  •RXXH302.H00 

•  REM  INCLUDE  THE  PROVIDER  DISK  WRITER 

06CF 

0EE8 

REM 

REH 

****  AMBULATORY  CARE  INFORMATION  SYSTEM  26  APR  85 

06CF 

OEEB 

REM 

SKIP  COLE 

•*»* 

06CF 

OEEB 

REH 

MODULE  NAME 

RXXM302.HOO 

06CF 

0EE8 

REM 

•***  SCANNER  PROGRAM  « 

:  300-PROVIOER  REGISTRATION 

*•** 

06CF 

0EE8 

REM 

06CF 

0EE8 

REM 

*•••  PURPOSE 

:  CREATE  AND  WRITE  THE  DISK 

06CF 

0EE8 

REM 

RECORD  FOR  INPUT  TO  FOCUS 

06CF 

0EE8 

REM 

06CF 

0EE8 

REM 

*•••  OUTPUT  RECORD  TYPES: 

06CF 

0EE8 

REM 

*•••  1  »  INITIAL  RECORD 

06CF 

0EE8 

REM 

*•••  2  »  CHANGE 

06CF 

0EE8 

REN 

•••*  3  »  PCS/CLOSE  OUT 

06GF 

0EE8 

REM 

06CF 

0EE8 

REN 

*•**  RESERVED  LINE  NUMBERS  :  200-299 

06CF 

0EE8 

REN 

06CF 

0EE8 

06CF 

0EE8 

REN 

BUILD  THE  OUTPUT  RECORD 

06CF 

0EE8 

0EE8 

OEEC 

OEEC 

OEEC 

OEEC 

OEEC 

OEEC 

OEEC 

OEEC 

OEEC 

OEEC 

OEEE 

OEEE 

OEEE 

OEEE 

OEEE 

OEEE 

OEEE 

OEEE 

OEEE 

OEEE 


R£C0OT$="300"+  TORS 


•TRANSACTION  CODE  300  +  TYPE  OF  RECORD 


RECOUTSs  RECOUTS  *  PROVIOS  *  ROATES  *  PROVCATS 

RECOUTS=  RECOUTS  ♦  PROVFHAHES  ♦  PROVLNAMES  ♦  PROVMINITS 

RECOUTS:  RECOUTS  +  PROVSSNS  *  PROVSTATS  *  PROVPOSNS 

RECOUTS:  RECOUTS  4-  PAYGRAOES  *  JO8C00ES  «  LITHOS 

PAO:MAXLENGTH  -  LEN(RECOUTS)  'FIND  OUT  HOW  SNORT  THE  RECORD  IS 

RECOUTS  :  RECOUTS  *  STRINGS(PAO,PAOS)  'PAD  THE  RECORD  WITH  FILL  CHAR 


PRINT  #1, RECOUTS 


REN 


-END  OF  MODULE  RXXH302. MOO- 


998  REM  CONTINUE 

999  READTYPE  »  2 


RACP300 

PROVIDER  OESTRIN6/DECOOE  PROGRAM 


PAGE  9 
06-Ca-87 
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Offset  Data  Source  Line  IBM  Personal  Con^ter  BASIC  Compiler  VI. 00 

0775  OEEE  IF  LN.CCUMT  >  48  THEM  G0SU8  7100  ‘PRINTER  HEADING 

0785  OEEE  GOTO  10 

0789  OEEE 

0789  OEEE  REM  ENO  OF  SCAN/DECQOE/WRITE  LOOP  ■»»«»•«»««»*««««««»»»»»«»«««*»«»=»«» 

0789  OEEE 

0789  OEEE  1000  REM  SINCLUDE:  'RACSIOOO.SUB*  Include  the  VERIFY  LOGON  SUB 

078A  OEEE  REM  w*******************************—***************—*************** 

078A  OEEE  REM  *  NAME:  RACS1000  LOGON  VERIFICATION  SUBROUTINE  * 

078A  OEEE  REM  *  Date:  28  Feb  84  PATIENT  REGISTRATION  PROGRAM  • 

078A  OEEE  REM  PATIENT  OMR  INPUT  PROGRAM  * 

078A  OEEE  REN  * 

078A  OEEE  REM  This  program  verifies  user  is  logged  on  properly.  If  there  is  no  * 

078a  OEEE  REM  valid  user  logged  on  at  the  time  of  execution,  this  subroutine  will* 

078A  OEEE  REM  chain  to  the  logon  program  RACPOS,  otherwise  a  return  is  issued.  * 

078A  OEEE  REM  ********************************************************************* 

0'78A  OEEE  REM  RESERVED  LINE  NUMBERS  ARE  1001  THRU  1010 

07SA  OEEE  REM  ********************************************************************* 

078A  OEEE  1001  OPEN  ••I'‘,1,"RACLOG.DAT'' 

079C  OEEE  IF  EOF(1)  THEN  1002  ‘MAKE  THEM  LOG  ON  FIRST 

07AA  OEEE  INPUT  #1,USEH$(1),0T$,TM$,PI0$ 

07C8  OEFA  IF  USERS(I)  »  ■"  THEN  1002  'MAKE  THEM  LOG  ON  FIRST 

0709  OEFA  IF  USERSd)  »  ■•*••***«  THEN  1002  'MAICE  THEM  LOO  ON  FIRST 

07E7  OEFA  CLOSE  1 

07EE  OEFA  SCREEN  0,1, 0,0 

0804  OEFA  COLOR  FORE, BACK, BORO 

081A  OEFA  CLS 

081E  OEFA  RETURN 

0821  OEFA 

0821  OEFA  1002  CLOSE 

0825  OEFA  CHAIN  "RACPOS" 

082C  OEFA  '====*=*=«==eHO  OF  LOGON  VERIFY  SUBROUTINE  1000==“===*=»»========«=»=**== 

062C  OEFA 


082C 

OEFA 

2000 

REM  SINCLUDE:  <RACS2000.SUB' 

Include  the  REPLT/DELAY  SUB 

0820 

OEFA 

REM 

A**** 

0820 

OEFA 

REM 

•**« 

AMBULATORY  CARE  DATA  BASE  13  APR  85 

0820 

OEFA 

REM 

•*** 

SKIP  COLE 

**** 

0820 

OEFA 

REM 

SUBROUTINE  NAME 

:  RACS2000.SUB 

**»* 

0820 

OEFA 

REM 

SCANNER  PROGRAM  « 

:  ALL 

**** 

0820 

OEFA 

REM 

*«*« 

FUNCTION 

:  THIS  SUBROUTINE  MODULE 

**** 

0820 

OEFA 

REM 

«•*«* 

SERVERS  AS  A  WAIT  AMO  REPLY 

***♦ 

0820 

OEFA 

REN 

***« 

ENTRY  MODULE 

««** 

0820 

OEFA 

REM 

nnt* 

INPUT 

:  SINGLE  KEYBOARD  ENTRY 

**** 

0020 

OEFA 

REM 

*««* 

**** 

0820 

OEFA 

REM 

**** 

OUTPUT 

KEYBOARD  ENTRY  -  UPPER  CASE 

***« 

0820 

OEFA 

REM 

**** 

*«** 

0820 

OEFA 

REM 

*«** 

RESERVED  LINE 

**** 

0820 

OEFA 

REM 

♦«** 

NUMBERS 

;  2001-2010 

•  *** 

0820 

OEFA 

REM 

L820 

OEFA 

2001 

REM  REPLY  FUNCTION 

082E 

OEFA 

2002 

REPLYS 

= INKEYS  :  IF  REPLYS*"" 

THEN  2002 

0842 

OEFE 

REPLY= 

ASC(REPLYS) 

084C 

OFOO 

IF  REPLY  >  90  THEN  REPLYS=CHR$(REPLY  XOR  32)  'CONVERT  TO  CAPS 

0"67 

OFOO 

IF  REPLYS  <  "A"  OR  REPLYS  >  ' 

Z"  THEN  REPLYS*"?" 

RACP300 

PKWIDEIi  DESTRING/0ECC06  PROGRAM 
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06-08-87 


Offset 

0893 

0896 

0896 

Data 

OFOO 

OFOO 

OFOO 

Source  Line 

RETURN 

5000  REM  SINCLUDE:  'RACSSOOO.SUB' 

Include  the  DATE  EDITOR  SUB 

IBM 

0897 

OFOO 

REM 

AMBUUTORY  CARE  DATA  BASE  13  APR  85 

*•«« 

0897 

OFOO 

REH 

SKIP  COLE 

0897 

OFOO 

REM 

*««« 

SUBROUTINE  NAME 

:  RXXS5000.SUS 

0897 

OFOO 

REH 

SCANNER  PROGRAM  # 

ALL 

0897 

OFOO 

REH 

FUNCTION 

THIS  SUBROUTINE  NODULE 

0897 

OFOO 

REM 

PERFORMS  A  DATE  EDIT 

0897 

OFOO 

REH 

0897 

OFOO 

REH 

*«•« 

INPUT 

DATE  TO  BE  CHECKED  MUST  BE 

0897 

OFOO 

REM 

•*** 

IN  THE  VARIABLE  NAMED 

**»* 

0897 

OFOO 

REM 

**•* 

•CK.5000S’ 

***• 

0897 

OFOO 

REM 

IN  THE  FORMAT  »YYMMOO“ 

*«•« 

0897 

OFOO 

REM 

*«*« 

**•* 

0897 

OFOO 

REM 

«*•« 

OUTPUT 

:  •RT.5000‘  IS  THE  RETURN  CODE 

***• 

0897 

OFOO 

REM 

*•** 

VARIABLE.  IF  THIS  VARIABLE 

0897 

OFOO 

REM 

CONTAINS  ANY  NUMBER  OTHER 

0897 

OFOO 

REM 

THAN  0,  AN  ERROR  UAS  FOUND 

0897 

OFOO 

REH 

«««« 

IN  THE  DATE. 

•«*« 

0897 

OFOO 

REM 

«•«* 

0897 

OFOO 

REN 

•*** 

RESERVED  LINE 

0897 

OFOO 

REM 

NUMBERS 

;  5001-5009 

•••• 

0897 

OFOO 

REN 

RT.5000  =  0 

089E 

OFOO 

CKYEAR  <  VAL(LEFT$(CK.5000S,2))  'YEAR  NUMERIC  VALUE 

0881 

0F02 

CKMONTH  =  VAL(MI0$(CK.5000$,3,2))  ’MONTH  NUMERIC  VALUE 

08C7 

0FO4 

CKDAY  <  VAL(RIGHTS(CK.S000$,2>}  'OAT  NUMERIC  VALUE 

080A 

0F06 

080A 

0F06 

IF  CKMONTH  <  1  THEN  RT.5000«1  :  GOTO  5009 

0870 

0F06 

IF  CKMONTH  >  12  THEN  RT.5000»1  ;  GOTO  5009 

0906 

0F06 

IF  CKDAY  <  1  THEN  RT. 5000*2  :  GOTO  5009 

091 C 

0F06 

IF  CKDAY  >  31  THEN  RT. 5000*2  :  GOTO  5009 

0932 

0F06 

0932 

OF06 

REH 

LEAP  TEAR  CHECK 

0932 

0F06 

NOLENGTH(2}  *  28 

0939 

0F06 

IF  CKMONTHO  2  THEN 

GOTO  5005  'MUST  BE  FEBRUARY 

0948 

0F06 

IF  (CKYEAR  MOO  4)  o  0  THEN 

GOTO  5005  'MUST  BE  A  LEAP  YEAR 

0950 

OF06 

HOLENGTH(2}  *  29 

0964 

0F06 

0964 

0F06 

5005 

IF  CKDAY  >  MOLENGTH(CKMONTH) 

THEN  RT. 5000*3  :  GOTO  5009 

0983 

0F06 

0983 

0F06 

5009 

RETURN 

0986 

0F06 

0986 

0F06 

0986 

OF06 

0986 

0F06 

0986 

0F06 

5010 

REH  SINCLUDE:  ■RACS5010.SUB' 

Include  the  NUMERIC  STRING  EDITOR 

0987 

0F06 

REN 

0987 

0F06 

REH 

**«• 

AMBULATORY  CARE  DATA 

BASE  1  MAY  85 

*•«* 

0987 

OF06 

REH 

•  *«* 

SKIP  COLE 

**«fk 

0987 

0F06 

REM 

**** 

SUBROUTINE  NAME 

:  RXXS5010.SU8 

**** 

0987 

0F06 

REM 

SCANNER  PROGRAM  « 

ALL 

*•** 

IBM  Personal  Coaster  BASIC  ConpUer  VI. 00 
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OffMt 

Data 

Source  Line 

IBM  Personal 

Computer  BASIC  Conpilc  VI. 00 

0987 

0F06 

REM 

FUNCTION  : 

THIS  SUBROUTINE  NODULE 

***« 

0987 

0F06 

REM 

**** 

PERFOmS  A  NUMERIC  STRING 

***• 

0987 

OF06 

REM 

EDIT. 

0987 

0F06 

REM 

#*** 

0987 

0F06 

REM 

INPUT  : 

STRING  TO  BE  EDITED  IS  IN 

**«* 

0987 

0F06 

REM 

**** 

THE  VARIABLE  NAMED 

0987 

0F06 

REM 

•CIC.5010S> 

•*** 

0987 

0F06 

REM 

•*** 

0987 

0F06 

REM 

•*«* 

OUTPUT  : 

•RT.5010‘  IS  THE  RETURN  CODE 

**** 

0987 

0F06 

REM 

«*** 

VARIABLE.  IF  THIS  VARIABLE 

**** 

0987 

OF06 

REM 

***« 

CONTAINS  ANY  NUMBER  OTHER 

0987 

0F06 

REM 

THAN  0,  AN  ERROR  UAS  FOUND 

**•* 

0987 

0F06 

REM 

*««« 

IN  THE  STRING. 

•••• 

0987 

0F06 

REM 

***• 

•««« 

0987 

0F06 

REM 

**** 

RESERVED  LINE 

•*** 

0987 

0F06 

REM 

NUMBERS 

5011-5019 

0987 

QF06 

REM 

0987 

0F06 

RT. 

5010  -  0 

098E 

0F06 

098E 

0F06 

FOR  IS010  ■  1  TO  LEN(CK.SOIOS) 

099E 

0F08 

JS010*  ASC(H1D$<CK.S010S, 

15010,1)) 

0982 

OFOC 

IF 

J5010  <  48  OR  J5010  > 

57  THEN  RT.5010  *  RI.5010  ♦  1 

09DA 

OFOC 

MEXT  15010 

09EB 

OFOC 

09EB 

OFOC 

RETURN 

09EE 

OFOC 

09EE 

OFOC 

7000 

REM  SINCLUDE:  'RACSTOOO.SUB’ 

Include  the  SCREEN  HEADER  SUB 

09ef 

OFOC 

REM 

09EF 

OFOC 

REM 

***« 

AMBUUTORY  CARE  DATA  BASE  13  APR  85 

•*** 

09EF 

OFOC 

REM 

SKIP  COLE 

09EF 

OFOC 

REM 

**** 

SUBROUTINE  NAME 

HACS7000.SUB 

*«** 

09EF 

OFOC 

REM 

***• 

SCANNER  PROGRAM  «  : 

ALL 

•*** 

09EF 

OFOC 

REM 

**«« 

FUNCTION  : 

THIS  SUBROUTINE  MODULE 

•  ••* 

09EF 

OFOC 

REM 

PRINTS  THE  STANDARD  SCREEN 

09EF 

OFOC 

REM 

*«*« 

HEADING. 

*•»* 

09EF 

OFOC 

REM 

**** 

INPUT  ; 

COMMON  VARIABLE  USERSIZ) 

**** 

09EF 

OFOC 

REM 

•««« 

SYSTEM  DATE 

**** 

o;ef 

OFOC 

REM 

*««* 

««•* 

09EF 

OFOC 

REM 

•••« 

OUTPUT  ; 

SCREEN  HEADING 

09EF 

OFOC 

REM 

«*•* 

09EF 

OFOC 

REM 

**** 

RESERVED  LINE 

09EF 

OFOC 

REM 

NUMBERS  : 

7001-7010 

09EF 

OFOC 

REM 

C9EF 

OFOC 

09EF 

OFOC 

7001 

LOCATE  1 

,1 

09F9 

OFOC 

PRINT  "U.S.  ARMY  AMBULATORY  CARE  INFORMATION  SYSTEM" 

0A01 

OFOC 

LOCATE  1 

,65 

O/OE 

OFOC 

PRINT  DATES; 

0A16 

OFOC 

LOCATE  2 

,1 

0a23 

OFOC 

PRINT  "USER  :  USERS! 1) 

0A30 

OFOC 

RETURN 

0a33 

OFOC 

7100 

REM  SINCLUDE:  'RACS7100.SU8' 

Include  the  PRINTER  HEADER  SUB 

0^34 

OFOC 

REM 

**•«•** 

*«****«*•«<»•**♦*«««**• 

RACP300 
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Offset 

Data 

Source  Line 

IBM  Personal  Conputer  BASIC  Conpiler  VI. 00 

0A34 

OFOC 

REM 

AMBULATORT  CARE  DATA 

BASE  13  APR  85 

0A34 

OFOC 

REM 

**«• 

SKIP  COLE 

ft*** 

0A34 

OFOC 

REM 

SUBROUTINE  NAME 

RXXS7100.SUB 

ft*** 

0A34 

OFOC 

REM 

SCANNER  PROGRAM  « 

ALL 

ft*** 

0A34 

OFOC 

REN 

FUNCTION 

THIS  SUBROUTINE  MODULE 

**** 

0A34 

OFOC 

REM 

PRINTS  THE  STANDARD  HEADING 

ft*** 

0A34 

OFOC 

REN 

ON  THE  PRINTER. 

*•** 

0A34 

OFOC 

REM 

INPUT 

OATE.PAGE.PCMIOS.PGMTITLS 

ft*** 

0A34 

OFOC 

REN 

ft*** 

0A34 

OFOC 

REN 

•••• 

OUTPUT 

PRINTER  HEADING,  LN.COUNT 

ft*** 

0A34 

OFOC 

REM 

«««* 

ft*** 

0A34 

OFOC 

REM 

RESERVED  LINE 

ft*** 

0A34 

OFOC 

REN 

NUMBERS 

7101-7110 

ft*** 

0A34 

OFOC 

REN 

0A3A 

OFOC 

0A34 

OFOC 

7101 

IF  PAGE  >  0  THEM  LPRINT  CHR$<12): 

0A4A 

OFOC 

LPRIMT 

"ARNY  AMBULATORY  CARE  INFORMATION  SYSTEM _ ••.-PCNTITLS; 

0A57 

OFOC 

LPRINT  TA8(70};0ATE$ 

0A6A 

OFOC 

PACE>PAGE+1 

0A72 

OFOC 

LPRIMT 

"PROGRAM  ".-PGMIDS.-TABITO.-HPAGE"; 

0A8F 

OFOC 

LPRINT  USING  ••««««••; PAGE 

0A9B 

OFOC 

LPRINT 

0AA3 

OFOC 

LN.CaUNT«3 

OAAA 

OFOC 

RETURN 

OAAO 

OFOC 

OAAO 

OFOC 

8000 

REM  SINCLUOE:  'RACSSOOO.SUB' 

Include  the  DECODE  SUB  GROUP 

OAAE 

OFOC 

REM 

Oaae 

OFOC 

REM 

AMBULATORY  CARE  DATA 

BASE  13  APR  85 

*** 

OAAE 

OFOC 

REM 

SKIP  COLE 

**• 

OAAE 

OFOC 

REM 

«*** 

SUBROUTINE  NAME 

RXXS8000.SUB 

•ft* 

OAAE 

OFOC 

REM 

•*«* 

SCANNER  PROGRAM  # 

ALL 

•ft* 

OAAE 

OFOC 

REM 

•**« 

FUNCTION 

THIS  SUBROUTINE  MODULE 

•ft* 

OAAE 

OFOC 

REM 

***« 

IS  A  GROUPING  THAT  PERFORMS 

•ft* 

OAAE 

OFOC 

REM 

VARIOUS  DECODING  FUNCTIONS 

•ft* 

OAAE 

OFOC 

REM 

«**« 

ON  THE  SCANNER  DATA 

•ft* 

OAAE 

OFOC 

REM 

*** 

OAAE 

OFOC 

REM 

8001  -  DECODE  THE 

HEADER  POSITIONS  (POINTER  0-20) 

•ft* 

OAAE 

OFOC 

REM 

8030  -  CHECK  FOR  END  OF  JOB 

•ft* 

OAAE 

OFOC 

REM 

***« 

8100  -  PRINT  THE 

HEADER  DATA  ON  THE  SCREEN 

•ft* 

OAAE 

OFOC 

REM 

•*** 

8200  -  DECODE  THE 

RESPONSE  POSITIONS  (POINTER  21-.. 

)  **• 

OAAE 

OFOC 

REM 

(RETURNED 

IN  TEXTS  STRING  VARIABLE) 

**• 

OAAE 

OFOC 

REM 

•** 

OAAE 

OFOC 

REM 

INPUT 

:  SHEET  RECORD,  RECORD  LENGTH 

•ft* 

OAAE 

OFOC 

REM 

**• 

OAAE 

OFOC 

REM 

OUTPUT 

:  'TEXTS'  THING  VARIABLE 

**• 

OAAE 

OFOC 

REM 

*•* 

OAAE 

OFOC 

REM 

*•** 

RESERVED  LINE 

•ft* 

OAAE 

OFOC 

REM 

NUMBERS 

:  8001-8500 

•ft* 

OAAE 

OFOC 

REM 

OAAE 

OFOC 

OAAE 

OFOC 

•DECODE  THE 

HEADER  ONLY 

OAAE 

OFOC 

8001 

POINTER  >  0 

OABS 

OFOE 

RECORDPTR  <  VARPTR(SHEETREC(0)) 

OABC 

0F10 

FOR  J8000  >  1  TO  21 

RACP300 

PfiOVIOER  DESTRIMG/DECOOE  PROGRAM 


Offset 

Data 

Source  Line 

0AC3 

0F10 

8002 

TEXTS'  TEXTS*CHRS(PEEK(RECOROPTR  *  POINTER)) 

0AE1 

0F10 

po:nter'Pointer+i 

0AE9 

OF10 

NEXT  J8000 

OAfe 

0F12 

PROGRAMS'  LEFTS(TEXTS,3) 

0B07 

OF  16 

BATCHS<  H1DS<TEXTS,4,3) 

0B19 

0F1A 

SERIALS'  HIDS<TEXTS,7,4) 

0B2B 

0F1E 

RUNIDS'  HIDS(TEXTS,11,1) 

0B3O 

0F22 

FORMS'  M10S<TEXTS.12,2) 

084F 

0F26 

POCKETS'  NI0S(TEXTS,14,1) 

0B61 

0F2A 

SCANERR1S'M1DS(TEXTS,16,2) 

0873 

0F2E 

SCANERR2S'MIDS(TEXTS, 18,2) 

0B8S 

0F32 

SCANERR3S'MIDS<TEXTS,20,2) 

0B97 

0F36 

GOTO  8500 

0B9B 

0F36 

0B9B 

0F36 

8050 

REM  CHECK  FOR  ENO  OF  J08/ENO  OF  BATCH 

0B9C 

0F36 

IF  PROGRAMS  >  PGM I OS  THEN  GOTO  8500 

OBAE 

0F36 

LPRINT  STR1NGS(80,"*") 

OBBC 

0F36 

LPRINT 

0BC4 

0F36 

LPRINT  "RECORDS  PROCESSED  ...  ".-SERIALS 

0BO1 

0F36 

LPRINT  “STARTED  AT  . ".‘BTIHES 

OBOE 

aF36 

LPRINT  "ENDED  AT  . ".-TIMES 

OBEB 

0F36 

LPRINT  CHRS(12) 

0BF6 

0F36 

GOTO  30000 

OBFA 

0F36 

03  FA 

0F36 

8070 

REM  CHECK  FOR  SCANNER  ERRORS 

08FB 

0F36 

IF  POCKETS  '  "  "  GOTO  8500 

OCOO 

0F36 

LPRINT  LITHOS; 

0C15 

0F36 

LPRINT  "  ...  SCANNER  ERRORS  : 

0C1D 

0F36 

LPRINT  SCAHERR1S;"  /  "; 

0C2A 

0F36 

LPRINT  SCAHERR2S;"  /  "; 

CC37 

0F36 

LPRINT  SCANERR3$ 

0C3F 

0F36 

LM=LN*1 

0C47 

0F3a 

GOTO  999 

0C4B 

0F38 

0C48 

0F38 

8100 

REM  PRINT  THE  HEADER  VARIABLES  ON  THE  TUBE.... 

0C4C 

0F38 

LOCATE  5,1: PH  I  NT  "PROGRAM  PROGRAMS; 

0C66 

0F38 

0C66 

0F38 

PRINT  "  BATCH  ";BATCHS; 

0C73 

0F38 

PRINT  "  RUN  ".-RUNIDS; 

UC80 

0F38 

PRINT  “  FORM  ".-FORMS; 

0C80 

0F38 

PRINT  "  POCKET  ".-POCKETS 

0C9A 

0F38 

GOTO  8500 

•0C9E 

0F38 

0C9E 

0F38 

8200 

REM  DECODE  THE  RESPONSE  POSITIONS 

0C9F 

0F38 

POINTER  »  21 

0CA6 

0F38 

RECOROPTR  *  VARPTR(SHEETREC<0)) 

OCAO 

0F38 

FOR  J8000  '  22  TO  RECOROLENGTH 

rcsA 

0F3A 

8202 

TEXTS  '  TEXTS+CHRSIPEEKIRECOROPTR  ♦  POINTER)) 

0CO8 

0F3A 

POINTER=POINTER*1 

OCEO 

0F3A 

NEXT  J8000 

CCFl 

0F3A 

Of  FI 

0F3A 

8500 

RETURN 

oc;4 

0F3A 

OCF'. 

Or3A 

REM  .  'ND  OF  RXXS8000.SUB  . 
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0#fs*t 

Cata 

Source 

Line 

IBM  Personal  Computer  BASIC  Compiler  VI .00 

0CP4 

0F3A 

0CF4 

0F3A 

9000 

REH  SINCLUDE:  'RACSOOOO.SUB* 

INCLUDE  THE  SCANNER  CONTROL  SUB 

0CF5 

0F3A 

REM 

****•*«*•••««*•*•««******♦«**«*•«*«**♦«*«««***•••*•*•««•«•*«•***••* 

0CF5 

0F3A 

REM 

•***  AMBULATORY  CARE  DATA  BASE  13  APR  8S 

••V* 

0CF5 

0F3A 

REM 

**«* 

SKIP  COLE 

0CF5 

0F3A 

REM 

•««  program  name 

RACS900Q.SUB 

•*** 

OCFS 

0F3A 

REM 

SCANNER  PROGRAM  « 

ALL 

•*** 

OCFS 

0F3A 

REH 

FUNCTION  ; 

THIS  SUBROUTINE  MODULE 

OCFS 

0F3A 

REM 

*«*« 

CONTROLS  THE  SCANNER  I/O 

OCFS 

0F3A 

REH 

#*•* 

OCFS 

0F3A 

REM 

•••*  INPUT/OUTPUT  : 

REFER  TO  THE  ASYNCHRONOUS 

**** 

OCFS 

0F3A 

REH 

COMMUNICATIONS  MANUAL  AND  THE 

•••* 

OCFS 

0F3A 

REM 

PRE-RELEASEO  SOFTWARE  GUIDE 

***• 

OCFS 

0F3A 

REM 

*•*« 

OCFS 

0F3A 

REN 

••••  RESERVED  LINE 

OCFS 

0F3A 

REM 

••••  NUMBERS 

9001-9100 

***• 

OCFS 

0F3A 

REH 

*««««**«««•*«*••«*«•«••*«««**«*««*«**«*«•«*•**••*••*«*«*«««*****•«« 

OCFS 

0F3A 

OCFS 

0F3A 

OCFS 

0F3A 

REM 

••••••••••••*****M«**1»******** 

OCFS 

0F3A 

REM 

••••  SUBROUTINE  9001  -  PROTOCOL  SETUP  FOR  SCANNER 

OCFS 

0F3A 

REH 

****  ARGUMENTS:  PRESET  ...  SEE 

BELOW 

OCFS 

0F3A 

REN 

OCFS 

0F3A 

9001 

REM 

0CF6 

0F3A 

PROTOCOLIO)  *  9600 

•BAUD  RATE 

OCFD 

0F3A 

PROTOCOL! 1)  »  78 

■PARITY  (SEE  PAGE  4-8  OF  MANUAL) 

0DQ4 

0F3A 

PR0T0C0L(2)  =  8 

■DATA  BITS 

XOB 

0F3A 

PR0T0C0L(3)  =  1 

•STOP  BITS 

0012 

0F3A 

PR0T0C0L(4)  =  2 

'RS-232  PORT 

0019 

0F3A 

PROTOCOL (5)  *  0 

•WRITE  TIME-OUT 

0020 

0F3A 

PROTOCOL (6)  »  0 

•READ  TIME-OUT 

0027 

0F3A 

0027 

0F3A 

ERRSTATS  >  SPACE$(60) 

0033 

0F3A 

ARGPTR  *  VARPTR(PROTOCOL<0)) 

003A 

0F3C 

CALL  SETUP  (ARGPTR, ERRSTATS) 

004B 

0F3C 

ERRMSGS*'"' 

OOS4 

0F3C 

IF  ASC(ERRSTAT$)  <>  64  THEM  ERRMSGS="SETUP  ERROR  «+ERRSTAT$ 

0070 

0F3C 

GOTO  9100 

0074 

0F3C 

0074 

0F3C 

REH 

0074 

0F3C 

REM 

**•*  SUBROUTINE  9010  -  CONTROL 

OPTIONS  FOR  SCAMMER 

0074 

0F3C 

REM 

••••  ARGUMENTS:  CNTRLOPT 

«•*** 

0074 

0F3C 

REM 

CNTRLOPT  =  1  =  START  SCANNER  (SI) 

0074 

OFK 

REM 

**•*  CNTRLOPT  *  2  =  STOP  SCANNER  (SO) 

0074 

0F3C 

REH 

*•••  CNTRLOPT  =  3  »  TERMINATE 

COMMUNICATIONS  TO  SCANNER  (DC3) 

0074 

0F3C 

REM 

*•••  CNTRLOPT  »  4  »  CLEAR  TRANSPORT  PATH  (0C2) 

0074 

0F3C 

REM 

***•  CNTRLOPT  *  5  =  SELECT  PRIMARY  STACKER  "31" 

0074 

0F3C 

REM 

CNTRLOPT  »  6  «  SELECT  SECONDARY  STACKER  "32" 

0074 

0F3C 

REM 

****  CNTRLOPT  =  7  *  POSITIVE  RESPONSE/SELECT  SCANNER  (0C1) 

0074 

0F3C 

REN 

***•  CNTRLOPT  »  8  =  REQUEST  STATUS  (ESC) 

0074 

0F3C 

REM 

0074 

0F3C 

9010 

REM 

0075 

0F3C 

ERRSTATS  »  SPACES(60) 

RACP300 

PROVIDER  DESTRING/DECOOE  PROGRAM 
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Off$«t 

Data 

Source  Line 

IBM  Personal  Conputer  BASIC  Conpiler  V1.00 

0081 

0F3C 

CALL  CMTROL  (CNTRLOPT.ERRSTATS) 

0092 

0F3C 

ERRHSGS««» 

0D9S 

0F3C 

IF  ASC(ERRSTATS)  <>  64  THEM  ERRHSGS^oCONTROL  ERROR  »+ERRSTATS 

0DB7 

0F3C 

GOTO  9100 

OOBB 

0F3C 

OOBB 

0F3C 

REH 

OOBB 

0F3C 

REM 

*•**  SUBROUTINE  9020  -  SCAN  SHEET  CALL 

OOBB 

0F3C 

REM 

*•** 

OOBB 

0F3C 

REM 

*•••  ARGUMENTS:  READTYPE 

OOBB 

0F3C 

REM 

READTYPE  a  2  *  REQUEST  NEW  DOCUMENT  FROM  SCANNER 

*«*«* 

OOBB 

0F3C 

REM 

••••  READTYPE  =  3  =  RETRANSMIT  CURRENT  DOCUMENT 

OOBB 

0F3C 

REM 

OOBB 

0F3C 

REH 

•**»  ARGUMENTS;  RECORDLENCTH 

OOBB 

0F3C 

REH 

****  NUMERIC  VARIABLE  SET  TO  THE  NUMBER  OF  CHARACTERS  TO  BE 

OOBB 

0F3C 

REM 

••••  TRANSMITTED 

OOBB 

0F3C 

REH 

OOBB 

0F3C 

9020 

REH 

OOBC 

0F3C 

ERRSTATS  >  SPACES(60) 

0OC8 

0F3C 

RECORDPTR  =  VARPTR(SHEETREC(0)) 

OOCf 

0F3C 

CALL  SCAN  (READTYPE, RECORDLENGTH^RECORDPTR, ERRSTATS) 

OCES 

0F3C 

ERRMSGS=:"" 

OOfI 

0F3C 

IF  HID$<ERRSTATI,14.3)  *  "415*  THEM  ERRMSG$=“ESC" 

0E12 

0F3C 

GOTO  9100 

0E16 

0F3C 

0E16 

0F3C 

REH 

0E16 

0F3C 

REH 

SUBROUTINE  9030  -  TRANSPORT  PRINT  CALL 

0E16 

0F3C 

REH 

«**• 

0E16 

0F3C 

REH 

ARGUMENTS:  PRINTPOS 

0E16 

0F3C 

REH 

NUMERIC  VARIABLE  INDICATING  THE  STARTING  PRINT  POSITION 

0E16 

0F3C 

REH 

VALUES  =  0  THRU  90 

0E16 

0F3C 

REH 

**** 

0E16 

0F3C 

REM 

••••  ARGUMENTS:  PSTRINGS 

*««** 

0E16 

0F3C 

REH 

****  TEXT  TO  BE  PRINTED  ON  THE  FORM 

0E16 

0F3C 

REM 

0E16 

0F3C 

REM 

NOTE:  THIS  ROUTINE  HAS  NO  EFFECT  UNLESS  THE  SCAN 

0E16 

0F3C 

REM 

HEADER  SHEET  IS  MARKED  'PRINTER  ON* 

r'E16 

0F3C 

REM 

0E16 

0F3C 

9030 

REH 

0E17 

0F3C 

ERRSTATS  =  SPACES(60) 

0E23 

0F3C 

RECORDPTR  =  VARPTR(SHEETREC(0)) 

0E2A 

0F3C 

CALL  TPR I  NT  ( PR  I NTPOS ,  PSTR I NGS,  ERRSTATS) 

0E3F 

0F42 

IF  ASC<ERRSTATI)  <>  64  THEN  ERRMSGS=»PR I  NT  ERROR  "♦ERRSTATS 

OESB 

0F42 

GOTO  9100 

0E5f 

0F42 

0E5f 

0F42 

9100 

RETURN 

0E62 

0F42 

REM  -■ 

. END  OF  SUBROUTINE  RACS9COO.SUB  . 

CE62 

0F42 

0E62 

0F42 

REM 

END  OF  SUBROUTINES  =============:=======*===“================; 

0E62 

0F42 

0Ei2 

0F42 

0E52 

0F42 

25000 

RFM  USER  TERMINATED  INPUT...  FILE  IS  NOT  TO  BE  USED'!!!! 

'1E63 

0F42 

LPRIMI  "USER  TERMINATED  INPUT  ..  DATA  WILL  NOT  BE  USED!" 

0t6B 

0F42 

LPRIMT  "ERASING  FILE  ".'DATFILS 

RACPSOO 

PROVIDER  OESTRIMG/OECOOE  PROGRAM 


Offset 

Data 

Source  Line 

0E7C 

0F42 

CIS  :  PRINT  "USER  TERMIMOATED 

0EB8 

0F42 

CLOSE 

OEBC 

0F42 

OPEN  OAT FILS  FOR  OUTPUT  AS  *1 

0E9E 

0F42 

PRINT  »1,STRINGS(RECOROLENGTH 

OEBO 

0F42 

CLOSE 

0EB4 

0F42 

0EB4 

0F42 

30000  REM 

0EB5 

0F42 

CLOSE 

0EB9 

0F42 

OPEN  «O",1,"RACB00.BAT« 

OECB 

0F42 

PRINT  #1, "RECOUP  RACPRSRT.BAT" 

0ED6 

0F42 

PRINT  #1,"RACB10" 

0EE1 

0F42 

CLOSE 

0EE5 

0F42 

END 

0EE9 

0F42 

OEEC 

0F42 

221S1  Bytes  Available 


DATA  WILL  NOT  BE  USEDC 


‘VOID  THE  FIRST  RECORD 


18186  Bytes  Free 
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0  Warning  Error(s) 
0  Severe  Error(s) 


Offset 

Data 

Source  Line 

a01A 

0002 

REN  SLINESI2E:  132 

001A 

0002 

REM  SPAGEStZE:  66 

001 A 

0002 

REM  ST  1 TIE:  'RACPGEN  • 

OOU 

0002 

REM  SSUBTITLE:  'GENERAL  FORM  DESTRING/OECOOE  PROGRAM 

001A 

0002 

REM  SPAGE 

PAGE  1 
Or-06-87 
U:51: 

IBM  Personal  Coitputei  BASIC  Conpiler  VI. 


§ 


RACPGEN 

GENERAL  FORM  OESTRING/OECOOE  PROGRAM 


Offset 

Data 

001A 

0002 

001A 

0002 

001A 

0002 

OOU 

0002 

001A 

0002 

001A 

0002 

001A 

0002 

001A 

0002 

001A 

0002 

OOU 

0002 

OOU 

0002 

OOU 

0002 

OOU 

0002 

OOU 

0002 

OOU 

0002 

OOU 

0002 

OOU 

0002 

OOU 

0002 

OOU 

0002 

OOU 

0002 

OOU 

0002 

OOU 

0002 

OOU 

0002 

OOU 

0002 

001A 

0002 

OOU 

0002 

OOU 

0002 

OOU 

0002 

OOU 

0002 

OOU 

0002 

OOU 

0002 

OOU 

0002 

OOU 

0002 

OOU 

0002 

OOU 

0002 

OOU 

0002 

OOU 

0002 

OOU 

0002 

OOU 

0002 

OOU 

0002 

OOU 

0002 

OOU 

0002 

OOU 

0002 

OOU 

0002 

OOU 

0002 

OOU 

0002 

OOU 

0002 

OOU 

0002 

OOU 

0002 

OOU 

0002 

OOU 

0002 

OOU 

0002 

OOU 

0002 

OOU 

0002 

PACE  2 
07-M-a7 
U:51;36 

Source  Line  IBM  Personal  Computer  BASIC  Compiler  VI. 00 

REM  . . . 

REM  I  NAME:  RACPGEN  AMBULATORY  CARE  INFORMATION  SYSTEM  | 

REN  I  DATE:  27  FEB  87  GENERAL  FORM  PROGRAM  j 

REM  I  0  R  BOLLING  j 

REM  . . . 

REM  GENERAL  FORM  OMR  INPUT  PROGRAM 

REM 

REM  This  program  reads  the  base  form  OMR  data,  converts  various 
REM  fields,  prints  an  error  report  and  produces  the  file: 

REM 

REN  VISIT.OAT 

REM 

REM  for  input  to  FOCUS.  NOTE  THAT  THIS  FILE  IS  OPENED  FOR  APPEND 
REM  each  time  the  program  is  run.  Thus,  if  the  file  does  not  exist, 

REM  records  will  be  added  to  the  front.  If  the  file  exists,  records 
REM  will  be  added  to  the  end  of  the  current  file.  It  is  intended  that 
REM  the  FOCUS  DIALOGUE  MANAGER  ROUTINE  which  loads  the  data  will  delete 
REM  the  data  file  after  the  load  has  been  successfully  acco«iplished. 

REM 

REM  If  there  is  no  valid  user  logged  at  the  time  of  execution,  this 
REM  program  will  chain  to  the  logon  program  RACP05,  otherwise, 

REM  the  program  chains  to  program  RACP10  on  exit. 

REM  SINCLUOE;  'RACOIM.MGO'  REM  INCLUDE  THE  DIMENSION  DEFINITIONS 


NAME:  RACOIM.MOO  DIMENSION  DEFINITIONS 

Date:  28  Feb  84  Written  by:  Floyd  Cole 

r***«********««*******«**««*«******«**«**«**«*****««************«i 

Dimensioned  variables  are  defined  in  this  file. 

It  is  an  included  file  so  it  cannot  be  run  in  a  stand-alone, 
mode. 


This  program  segment  may  be  modified,  but  all  files  containing 
an  include  for  this  segment  must  be  re-compiled  in  order  to 
affect  the  changes  made  here. 

•**.*•*****•  start  of  dimension  DEFINITION  ••*••*•••••••••••••' 


DEFINT  A-2 

DIN  USERS(2},MOLENGTN(12),DATEERR$(3) 
•••••*•*••*•  END  OF  DIMENSION  DEFINITIONS 


REN  DIMENSION  STATEMENTS  UNIQUE  TO  THIS  PROGRAM 


DIM  SHEETRECdTSO) 
DIM  PROTOCOL (7) 
DIN  NRESPISO) 

DIM  PROCNlSO) 

DIN  NS0X(80) 

DIM  NOTHlSO) 

DIM  ccuao) 

DIM  CC2(80) 

DIM  CC3(B0) 


'(MAX.  SIZE  FOR  A  SHEET  FROM  THE  SCANNER) 
■(ARRAY  FOR  SERIAL  BOARD  SETUP  PARAMETERS) 
'(NUMBER  OF  RESPONSES  FOR  EACH  FORM) 

'(NUMBER  OF  PROCEDURES  ON  EACH  FORM) 

'(NUMBER  OF  SECONDARY  DX  COOES  ON  EACH  FORM) 
'(NUMBER  OF  OTHER  COOES  ON  EACH  FORM) 

■NUMBER  OF  PRIM  OX  IN  COL  1 
■NUMBER  OF  PRIM  DX  IN  COL  2 
■NUMBER  OF  PRIM  OX  IN  COL  3 


RACPGEN 

GENERAL  FORM  DESTRING/OECOOE  PROGRAM 
OffMt  Data  Source  Line 
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IBM  Personal  Computer  BASIC  Compiler  VI. 00 


001A 

0002 

DIM  CCL(80) 

•NUMBER  OF  PRIM  DX  IN  COL  4 

001A 

0002 

DIM  CLIDEFSieO) 

■CLINIC  DEFAULT  COOES 

001A 

0002 

DIM  CLIBUaS(80) 

•SINGLE  BUBBLE  CLINIC  COOES 

001A 

0002 

DIM  REFC0$(26) 

•SINGLE  BUBBLE  REFERRAL  COOES  PHYS  THER 

001A 

0002 

DIM  REFCTS(26) 

•SINGLE  BUBBLE  REFERRAL  COOES  OCCU  THER 

001A 

0002 

DIM  0PT0HS(21) 

•OPTOMOTRY  OTHER  CODES 

001A 

0002 

DIM  ORTHOS(107) 

•ORTHO  APPL  OTHER  COOES 

001A 

0002 

DIM  RHEUMSdD 

•RHEUMATaOGY  OTHER  COOES 

001A 

0002 

DIM  SOCUOSd) 

•SOCIAL  WORK  OTHER  COOES 

OOU 

0002 

DIM  DIALY$(2A) 

•DIALYSIS  OTHER  COOES 

001A 

0002 

DIM  NEUR0S(29) 

■NEUROSURGERY  OTHER  COOES 

001A 

0002 

DIM  PHYTH$d9) 

•PHYSICAL  THERAPY  OTHER  COOES 

OOIA 

0002 

DIM  PSC0LS(3A) 

•PSYCHOLOGY  OTHER  COOES 

001A 

0002 

DIM  PSYCHS(30) 

•PSYCHIATRY  OTHER  COOES 

001A 

0002 

DIM  PSYASS(4) 

'PSYCHOMETRIC  ASSESSMENTS  COOES 

OOIA 

0002 

DIM  YNS(3) 

•(YES/NO  ANSWERS  0*1,  1  <  Y  ,  2>N  ,  S*X) 

OOIA 

0002 

DIM  ED.HSG$(30) 

•(ERROR  MESSAGES  FROM  EDIT  ROUTINES) 

OOIA 

0002 

DIM  CLINICI.PFXS(S) 

•(PREFIX  -B  0  F  G  S-  FOR  CLINIC  *1) 

OOIA 

0002 

DIM  CLINIC2.PFX$(6} 

•(PREFIX  -A  B  C  D  F  S-  FOR  CLINIC  «2) 

OOiA 

0002 

DIM  PROVIDER. TtHE$(22)  '(TIME  TABLE  FOR  PROVIDERS) 

OOU 

0002 

DIM  PROCEO$d25) 

•(PROCEDURE  TABLE  FOR  BASE  FORM) 

OOU 

0002 

DIM  0IAGN.TAB$(22S) 

•(DIAGNOSIS  TABLE  FCXl  BASE  FORM) 

OOU 

C302 

DIM  H0LDS(99) 

•(HOLD  AREA  FOR  SUBROUTINE  6000) 

OOU 

0002 

DIM  SPECLS<09) 

•(SPECIAL  PROGRAMS) 

OOU 

0002 

OOU 

0002 

REM 

$INCLUOE:  'RACCMN.MOO 

REM  INCLUDE  THE  COMMON  AREA  DEFINITION 

OOU 

0002 

1**1 

f* 

OOU 

0002 

I* 

NAME:  RACCMN.MOO 

COMMON  AREA  DEFINITION 

• 

OOU 

0002 

1* 

Date:  28  Feb  84 

Written  by;  Floyd  Cole 

• 

OOU 

0002 

1**1 

»* 

OOU 

0002 

1 

COMMON  AREA  DEFINITIONS  WILL  BE  HELD  IN  THIS  FILE.  IT  IS  AN 

OOU 

0002 

1 

INCLUDED  FILE  SO  IT  CANNOT  BE  RUN  IN  A  STAN0*AL0NE,  MODE. 

OOU 

0002 

1 

OOU 

0002 

1 

This  program  segment  may  be  modified,  but  all  files  containing 

OOU 

0002 

f 

an  include  for  this  segment  must  be  re*compiled  in  order  to 

OOIA 

0002 

1 

affect  the  changes  made  here. 

OOU 

0002 

1 

OOU 

0002 

1 

*********»***START  OF 

COMMON  DEF I  MI T IONS************************ 

OOU 

0002 

OOU 

0002 

COMMON  FORE, BACK, BOARD 

N I OE,E FORE, EBACK, BELLS  'BASIC  SCREEN  COLORS 

OOU 

0002 

COMMON  HEADERS 

'21  CHARACTER  SCANNER  HEADER  INFO 

onu 

0002 

COMMON  TEXTS 

■■  AIMING  CHARACTERS  FROM  SCANNER 

OOU 

0002 

COMMON  PGM I OS 

•PROGRAM  OR  FORM  ID 

OOU 

0002 

COMMON  MOLENGTHO 

•DAYS  IN  THE  MONTH 

OOU 

0002 

COMMON  USERtO 

OOU 

0002 

1 

COMMON  0EFIMITIOM****»********»*»**»»**»** 

OOU 

0002 

OOU 

0002 

OOU 

0002 

REM 

SINCLUOE:  'RACDEF.MOO 

REM  INCLUDE  THE  DEFAULT  DEFINITIONS 

OOl  A 

0002 

1 

1  (1 

OOU 

0002 

1  * 

NAME;  RACP01.0EF 

DEFAULT  DEFINITIONS 

* 

OOU 

0002 

1  * 

Date:  28  Feb  84 

Written  by:  Floyd  Cole 

* 

OOIA 

0002 

1  a  A 

CO  M 

0002 

• 

Variables  used  in  f'Mir 

non  that  have  a  default  value  on  start*up 

Variables  used  in  r  aninon  that  have  a  default  value  on  start*up 


RACPGEN 

GENERAL  FORM  DESTRING/DECOOE  PROGRAM 
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001A  0002  '  will  be  held  in  this  file.  It  is  an  included  file  so  it  cannot 

001A  0002  '  be  run  in  a  stand*alone  mode.  In  normal  operation,  this  file 

001A  0002  '  should  be  'included'  in  the  main  program  only  <RA^10.BAS). 

001A  0002  ' 

OOIA  0002  '  This  program  segment  may  be  modified,  but  all  files  containing 

001A  0002  '  an  include  for  this  segment  must  be  re*compiled  in  order  to 

OOIA  0002  '  affect  the  changes  made  here. 

OOIA  0002  • 

OOIA  0002 

OOIA  0002  '  •"••••••••••START  OF  DEFAULT  OEFINITIQN*^^^^^^******^^*^******' 


OOIA 

0002 

FORE  •  15 

'FOREGROUND  COLOR  <  INTENSE  UNITE 

005E 

231C 

BACK  •  1 

'Background  Color  «  Light  Blue 

0065 

231 C 

BORO  •  4 

'BORDER  >  RED 

006C 

231E 

HIOE  >  4 

'ALTERNATE  COLOR  >  RED 

0073 

231E 

EFORE>  14 

'ERROR  FOREGROUND  DISPLAY 

007A 

231E 

EBACK>  0 

'ERROR  BACKGROUND  DISPLAY 

0081 

231E 

BELLS  ■  CHRS(7) 

'Sound  the  bell 

0080 

231E 

0080 

231E 

MOLENGTH(I) 

* 

31  'JAN 

0094 

231E 

MOLENGTH(2) 

M 

28  'FEB  <--MQOIFlEO  IN  SUBROUTINE  RACS5000.I 

0098 

231E 

MOLENGTH(3} 

* 

31  'MAR 

00A2 

231E 

MOLENCTH(4) 

9 

30  'APR 

00A9 

231E 

H0LENGTH(5) 

9 

31  'MAY 

0080 

231E 

M0LENGT)f(6} 

9 

30  'JUN 

00B7 

231E 

MOLEMGTH(7) 

« 

31  'JUL 

OOBE 

231 E 

M0LENGTH(8) 

9 

31  'AUG 

00C5 

231E 

M0LENGTH(9} 

9 

30  'SEP 

OOCC 

231E 

HOLENGTH(IO) 

9 

31  'OCT 

0003 

231E 

MOLENGTH(II) 

9 

30  'NOV 

OOOA 

231E 

MOLENGTH(12) 

9 

31  'DEC 

00E1 

231E 

00E1 

231E 

DATEERRSCO) 

9 

H  II 

OOEA 

231E 

OATEERRSd) 

S 

"INVALID  MONTH" 

OOF3 

231E 

DATEERRS(2) 

9 

•'INVALID  DAY  " 

OOFC 

231E 

0ATEERR$(3) 

9 

"DAY  TOO  LARGE  FOR  MONTH  COOED" 

0105 

231 E 

0105 

23  IE 

MAXLENGTH 

= 

80  'MAXIMUM  LENGTH  OF  OUTPUT  RECORD 

01 OC 

2320 

PADS 

9 

'PAD  CHARACTER  FOR  SHOTT  RECORDS 

0115 

2324 

0115 

2324 

•END  OF  DEFAULT  0EFINITION*******^*****»»»»»»*»»*» 

0115 

2324 

0115 

2324 

0115 

2324 

KEY  OFF 

011B 

2324 

011B 

2324 

REM  •••••*•*•**• 

99* 

011B  2324  REM  PROGRAM  PARAMETERS 

01 1B  2324  NRESP(40>=282  :  PR0CN(40)=028  :  NSDX(40)=-02  :  NOTH(40)=00 
0137  2324  NRESP(41)=255  :  PROCN(41)=043  :  NSOX(41)=-01  :  NOTH(41)=00 
0153  2324  NRESP(42)=270  :  PR0CN(42}:049  :  NSDX(42):-01  :  NOTH(42)=00 
016F  2324  NRESP(43)*302  :  PROCN<43)=029  :  NS0X<43)*-01  :  NOTH(43)=00 
0188  2324  NRESP(44)°2S5  :  PROCN(44):015  :  NSOX(44)<:-OQ  :  NOTH(44):00 
01A7  2324  NRESP(45)*445  :  PROCN(45)«092  :  MSOX(45)=-01  :  NOTH(45)=00 
01C3  2324  NRESP(46)=184  :  PROCM(46)=010  :  MS0X(46)=-01  ;  NOTH<46)=00 
01DF  2324  NRESP(47)=284  :  PR0CM(47)=041  :  NS0X(47)«-01  :  NOTH(47)=00 


RACPGEN 

GENERAL  FORM  OESTRINC/DECOOE  PROGRAM 


Offset  Data  Source  Line 


01 FB 

2324 

NRESP(48}=294 

:  PROCN(48>=016 

NS0X(48)=-02 

0217 

2324 

NRESP(49)=272 

:  PROCN(49)<029 

NS0X(49)*-01 

0233 

2324 

HRESP(S0)=301 

:  PROCH(50)=036 

HSOX(SO)«-01 

024F 

2324 

NRESP(S1}>38S 

:  PROCN(S1)>058 

NS0X(51)«-02 

026B 

2324 

NRESP(S2}>209 

:  PR0CN<52)=017 

NS0X(S2>*-01 

0287 

2324 

NRE5P(S3)=209 

:  PROCN(53)=013 

NS0X(S3)«-02 

02A3 

2324 

NRESP(54)=359 

:  PROCH(54)>064 

MS0X(54)a-01 

OEBF 

2324 

NRESP<S5)=350 

:  PROCN(55>=017 

NS0X(S5)a-01 

02DB 

2324 

NRESP(56)=372 

:  PROCN(S6)=020 

HS0X(56)=-02 

02F7 

2324 

NRESP(S7)=000 

:  PROCN(57)=000 

NSOX(S7)=000 

0313 

2324 

NRESP(58)=289 

:  PROCN(58)a038 

HS0X(58)a-02 

032F 

2324 

NRESP(S9)=286 

:  PR0CN(59)=044 

HS0X(59)=-02 

034B 

2324 

NRESP(60)=300 

:  PROCN(60)=024 

NSDX(60)>-01 

0367 

2324 

NRESP(61 >=293 

:  PROCN(61)=041 

NS0X(61)>-02 

0383 

2324 

HRESP(62)=332 

:  PROCN<62)=OS1 

NSOX<62}>-02 

039F 

2324 

NRESP(63)=313 

:  PROCN(63)a041 

NS0X(63)«  00 

03BB 

2324 

NRESP(64}=288 

:  PROCH(64)>02S 

NS0X(64)>-01 

0307 

2324 

NRESP<65}=448 

:  PROCN(6S>>120 

NSOX(65)«-02 

03F3 

2324 

NRESP(66)=3a4 

;  PROCN(66)=0Sa 

NS0X<66)=-01 

040F 

2324 

NRESP(67)=315 

:  PROCN(67)=040 

NS0X(67)«-02 

042B 

2324 

NRESP(68)=352 

;  PROCN(68)=065 

NSDX(68>=-02 

0447 

2324 

HRESP<69)»249 

:  PROCK<69)*022 

NS0X(69)=-01 

0463 

2324 

NRESP(70)=3Q3 

!  PROCM<70>=051 

MS0X(70>«-01 

047F 

2324 

NRESP<71)=332 

!  PROCH{71 >*056 

HSDX(71>»-02 

0498 

2324 

NR£SP<72)=233 

;  PROCN<72>«012 

NSOX(72)*-02 

04B7 

2324 

MRESP(r3)a341 

:  PROCN(73)»010 

NSOX{73)»-02 

04D3 

2324 

NRESP<74)=37S 

:  PROCH<74)=038 

NSOX(74)=-00 

04EF 

2324 

NRESP<75)=264 

:  PROCN(75)=036 

NS0X(75>=-01 

030B 

2324 

NRESP(76)=000 

:  PROCN(76)=000 

NSOX<76><000 

0527 

2324 

NRESP(77)=263 

:  PROCM<77)=009 

NS0X(77)»-01 

0543 

2324 

NRESP<78)=296 

:  PROCN<78)=034 

NSDX(78}=-01 

055  F 

2324 

NRESP(79)=303 

:  PROCN(79>=056 

HS0X(79)=-01 

057B 

2324 

0578 

2324 

CC1<40)=34 

:  CC2(40)=35 

CC3(40)=30 

0597 

2324 

CC1(41)=17 

:  CC2(41)=19 

CC3<41)«31 

05B3 

2324 

CC1<42)=31 

:  CC2(42)=28 

CC3(42)=11 

05CF 

2324 

CC1(43)=43 

:  CC2(43)=34 

CC3(43)=33 

05EB 

2324 

CC1(44)=37 

:  CC2(44)=28 

CC3(44)=28 

0607 

2324 

CC1(45>=42 

:  CC2(45>=43 

CC3{45)=44 

0623 

2324 

CC1(46)=18 

:  CC2(46)=18 

CC3(46)=26 

063F 

2324 

CC1(47)=25 

;  CC2(47)=37 

CC3(47)=20 

065B 

2324 

CC1(48)=48 

:  CC2(48)*41 

CC3(48}=42 

0677 

2324 

CC1(49)=33 

:  CC2(49)=40 

CC3<49>=39 

0693 

2324 

CC1(50)=26 

;  CC2(50)=3S 

CC3(50)=42 

06AF 

2324 

CC1<51)=44 

:  CC2(51)=44 

CC3(51)=46 

06CB 

2324 

CC1(52)=30 

:  CC2{52)=24 

CC3<52).19 

06E7 

2324 

CC1<53)=25 

:  CC2(53)=27 

CC3(53)=18 

0703 

2324 

CC1(54)=31 

:  CC2(34)=37 

CC3<54)=18 

071 F 

2324 

CCU55)=59 

:  CC2(55)=62 

CC3(55)=50 

0738 

2324 

CC1(56)=60 

:  CC2(56)=62 

CC3(56)=61 

■'737 

2324 

CCU57)=00 

:  CC2<57)=00 

CC3(57)=00 

0773 

2324 

CC1(58)=42 

;  CC2(58)=38 

CC3(58)=32 

073  F 

2324 

CC1(59)=25 

;  CC2(59)=24 

CC3(59)=54 

07An 

2324 

CC1(60)=40 

;  CC2(60)=35 

CC3(60)=39 

PACE  5 
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NOTH(A8)<00 

NOTH(49}«00 

NOTH(S0>>00 

NOTH(51)*00 

NOTH(52>cOO 

MOTH(53)‘00 

MOTH(S4)<24 

NOTH(S5)>00 

NOTH(56)°29 

NOTH(S7)«00 

NOTH(58)<00 

NOTH(39)*00 

NOTK(60)=00 

NOTH(61)<>00 

NOTH(62>>21 

NOTH(63)«i07 

NOTH(64)eOO 

NOTH(6S)>00 

NOTH(66>-00 

NOTH(67)°00 

NOTH(68)=19 

NOTH(69>'00 

MOTH(70)»00 

MOTH{71 >=00 

NOTH(72)*00 

NOTH(73)=30 

NOTH(74)=34 

NOTH(75)=00 

MOTH(76)=00 

NOTH(77)=U 

MOTH(78)=01 

NOTH(79)=00 

CC4(40)=24 

CC4(41>=00 

CC4{42)=00 

CC4(43)=30 

CC4(44)=27 

CC4(45)=28 

CC4(46)=00 

CC4(47)=16 

CC4(48)=28 

CC4(49)=00 

CC4(S0)=22 

CC4(5n=32 

CC4(52>=00 

CC4(53)=10 

CC4(54)=17 

CC4(55)=41 

CC4(56)=17 

CC4(57)=00 

CC4(58)=00 

CC4(59)=12 

CC4(60)=34 


RACPCEN 

GENERAL  FORM  DESTRING/DECODE  PROGRAM 


I 

■ 

I 

I 

I 


Offset 

Data 

Source  Line 

07C7 

2324 

CC1 (61 )a30 

CC2<61)=28 

CC3(61 )»32 

CC4(61)>18 

07E3 

2324 

CC1(62)a34 

CC2(62)::30 

CC3(62)>26 

CC4(62>*16 

07FF 

2324 

CC1(63)=12 

CC2(63)=11 

CC3(63)«00 

CC4<63)>00 

081B 

2324 

CC1(64)=35 

CC2(64):43 

CC3(64)>33 

CC4(64)e23 

0837 

2324 

CC1(6S)a28 

CC2(6S)331 

CC3(65)»31 

CC4<65)«15 

0853 

2324 

CC1(66)a38 

CC2(66)^3 

CC3(66)=21 

CC4(66>*00 

086F 

2324 

CC1<67)=25 

CC2(67)»45 

CC3{67)»37 

CC4(67)«25 

088B 

2324 

CC1(68)=37 

CC2(68)>34 

CC3{68)«17 

CC4(68)>12 

08A7 

2324 

CC1(69)a22 

CC2(69)*27 

CC3(69)«26 

CC4(69)>26 

08C3 

2324 

CC1(70)=18 

CC2(70)*42 

CC3<70)»39 

CC4(70)<00 

08OF 

2324 

CC1(71)=32 

CC2(71)*31 

CC3<71)»34 

CC4(71)*20 

08FB 

2324 

CC1{72)=34 

CC2(72)=29 

CC3(72)a2a 

CC4(72>«15 

0917 

2324 

CC1(73)=60 

CC2(73)»52 

CC3<73)«55 

CC4(73)a14 

0933 

2324 

CC1(74)a52 

CC2(74)«40 

CC3<74)»S9 

CC4(76)*00 

094F 

2324 

CC1(75)*40 

CC2(75)»25 

CC3<75)*2S 

CC4(75)»00 

096B 

2324 

CC1(76)e00 

CC2<76)»00 

CC3(76)«00 

CC4(76)«00 

0987 

2324 

CC1(77)a36 

CC2<77)=32 

CC3<77)*34 

CC4(77)=28 

09A3 

2324 

CC1<78)«30 

CC2<78)=35 

CC3(78)«29 

CC4(78)»22 

09BF 

2324 

CC1(79)a19 

CC2(79)»23 

CC3(79)»33 

CC4(79)«12 

0908 

2324 

PACE  6 
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090B 

090B 

09F6 

0A11 

0A2C 

0A47 

0A62 

0A7D 

0A98 

0AB3 

OACE 

0AE9 

0B04 

0B1F 

0B31 

0B43 

0B43 

0B43 

0B4C 

0B55 

OBSE 

0B67 

0870 

0879 

0B82 

0B8B 

0894 

0B9O 

0BA6 

OBAF 

0BB8 

OBCI 

OBCA 

0BD3 


2324 

2324 

2324 

2324 

2324 

2324 

2324 

2324 

2324 

2324 

2324 

2324 

2324 

2324 

2324 

2324 

2324 

2324 

2324 

2324 

2324 

2324 

2324 

2324 

2324 

2324 

2324 

2324 

2324 

2324 

2324 

2324 

2324 

2324 


REM 


**•  DEFAULT  CLINIC 
CLIDEF$(4Q}>»BDBA‘' 
CLI0EF$(41)*"8ABA" 
CLI0GFS(42)>«BH0A<' 
CLIDEFS(43)="BACA" 
CLI0EF$(44)="BBBA" 
CLIDE F$(45)="BAPA“ 
CLIDEF*(46)="BAFA" 
CLI0EFt<47)=>"BBFA'' 
CLI0EF$<48}»''BGTA'' 
CLIDEF»(49)=''BAGA" 
CLIDEF$(50)=''BBAA'' 
CLIDEF$<51)=''BCBA'' 
CLI0EF$(52)=''BAQA" 
CLIDEF$<53)«''BAAA" 


CODE  TABLE 

CLIDEFS(54)«"BA  IA“ 

CLI0EF$(55)<i"BA  Jl" 

CLIDEF$(S6>>"BBCA» 

CLI0EF$<57)="  " 

CLIDEF$(58)»"BALA" 

CLIDEFt(59)="BCCA" 

CLI0EF$(60)»"BAMA" 

CLtOEF$(6U>»BBOA” 

CLIDEF$<62)«''8HCA" 

CLI0EF$(63)=“BEEA" 

CLIDEF$<64)=''BEAA" 

CLI0EF$(65)="DMBA" 

CLIDEF$(66)=''B8AB" 

CLI0EF$(67)="BDAA" 


CLIDEF$(68)>''DHDA» 
CLIDEF$<69)*"BBCA» 
CLIDEFS(70)*“BEFA« 
CLI0EF*<71)«“FBBA" 
CLIDEF$(72)«"BHAA» 
CLIDEFS<73)*"BFAA" 
CLI0EF$(74)»"BFBA» 
CLIOEF»(75)»"BANA" 
CLIDEF$(76)«"  " 
CLIDEF*(77)«"BA0A" 
CLI0EF$(78)="BFEA'' 
CLIDEF$(79)»"BBIA" 


REM 


CLINIC  CODE  BY  SINGLE  BUBBLE  • 
CL  I  BUB$(  40  )="BOAABGY  Nau  I  A„;,A  A  ' 
CLIBUB$(42)="BHEA" 

CLIBUBJ<43)="00AA" 

CLIBUB*(45)=''0MCA" 

CLIB08${48)="BGYM'' 

CLIBUBS<49}>’'8aHA'' 

CL  I BUBS(5 1 } e»BCYABCAABGYN" 

CL  I BUBS( 53 ) ="BAE ABA  I A" 
CLIBUB$(54)=''0GBA" 

CLIBUB$(SS):''BAAA'' 

CLIBUB$(59)="BGYABCCCBGYN" 

CLIBUB$(60):"BAMB8AHABAAA" 

CL  IBUBS(62 1’^OBHCHBHC  I " 
CLIBUB$(63)="BEBA" 

CL  I BUB$(64 )=“BEBABE  FA" 
CLIBUB${66)="0HCA" 

CL  I BU8t(67):"S08ABGYA6HAAB0CABGYNB I YA" 


•ADOLESCENT  MEDICINE 

•AUOIOLOGY/SPEECH 

•CARDIOLOGY 

•DERMATOLOGY 

•FAMILY  PRACTICE 

•GASTROENTEROLOGY 

•GYNECOLOGY 

•INTERNAL  MEDICINE 

•NEPHROLOGY 

•NEUROLOGY 

•OBSTETRICS 

•ONCOLOGY 

•OPTOMETRY 

•ORTHO  APPL 

•ORTHOPEDICS 

•PAIN/PHYS  MED 

•PEDIATRICS 


RACPGEN 

GENERAL  FORM  DESTRIHG/OECOOE  PROGRAM 


Offset 

Data 

Source  Line 

080C 

2324 

CL1BUBS(68)«'*BEOABEDAOHOA''  'PHYS  THER 

-LAST  TUO  ARE  TOGETHER 

OBES 

2324 

CLtBUB$(71  Ix^FBAABAOA* 

PREVENTIVE  MEDICINE 

OBEE 

2324 

CL  I BUBS(72 )s»BHBAB JYA" 

PRIMARY  CARE 

06F7 

2324 

CL  I  B(JB$(  73  }>'‘BF0ABFCA« 

PSYCHIATRY 

OCOO 

2324 

CL1BU8S(74)s«BFDABFAABFCA'‘ 

PSYCHOLOGY 

0C09 

2324 

CL  I  BU8$(  75  )=‘'OODADHAA“ 

PULMONARY 

0C12 

2324 

CLIBUB$<77)a“BAAA" 

•UROLOGY 

0C1B 

2324 

CLIBUBS(78)e"BF0ABFEB" 

SOCIAL  UORK 

0C24 

2324 

0C24 

2324 

REM 

***  SINGLE  BUBBLE  REFERRAL  COOES  (FORM  680-PHYS  THER  ONLY)  *** 

0C24 

2324 

REFCOf<00)»“  « 

REFC<»(09)="BBCA* 

REFCOS(18)«“BHAG" 

0C3F 

2324 

REFCOS(01)s'‘AAAA" 

REFCOS(10)>''BEAA'‘ 

REFC0$(19)*"BHAH“ 

OCSA 

2324 

REFCO$(02)3«ABAA" 

REFCOS(11)»'*BEOA“ 

REfCOS(20)<"BHAI" 

0C75 

2324 

REFCOS(03)a<‘AEAA‘* 

REFC0$(12)»“BEFA“ 

REFCOS(21)*“BHAK" 

OC90 

2324 

REFCOSCOAl^xBAAAo 

REFCO$(13)*“BOAA” 

R£FCO$(22)«"BHAL" 

OCAB 

2324 

REFCQ$(OS)*“SACA“ 

REFC0$(14)*"BGYA“ 

REfCO$(23)*"BHAM" 

C.:C6 

2324 

REFCOS(06)»"8AKA“ 

REFC0S(15)="BHAA" 

REFC01(24)*"BIYA" 

0CE1 

2324 

REFCOS(07><"BAOA" 

REFCCS(16)»''BHAE” 

REFCO$(25)»"BJYA" 

OCFC 

'2324 

REFCO$(08)*‘<BBAA» 

REfC0$(17)*"BHAF“ 

REFCOS(26)""DHCA" 

0017 

2324 

0017 

2324 

REM 

•••  SINGLE  BUBBLE  REFERRAL  COOES  (FORM  650-0CCU  THER  ONLY)  ••• 

0017 

2324 

REFCT$(00)«“  « 

REFCT$(09)*'>BAAA" 

REFCT$(18)»"BGYA» 

0032 

2324 

REFCTS(01)»"AAAA" 

REFCT$(10)*"BACA« 

REFCTS(19)»"BHAA" 

0040 

2324 

REFCT$(02)»"AAAF" 

REFCT$(11)*"8AKA“ 

REFCTS(20)»"BHAB" 

0068 

2324 

REFCT$(03)»"AABA" 

REFCT$(12)="BBAA" 

REfCTS(21)»"8HAE" 

0083 

2324 

REFCT$(04)*"A8AA" 

REFCTS(13)«"B8CA» 

REFCT$(22)s"8MAF" 

009E 

2324 

REFCT$(05)»"AB0A" 

REFCT$(14)="B80A“ 

REFCT$(23)=“BHAG" 

00B9 

2324 

REFCT$(06)="AEAA" 

REFCT$(15)="80AA" 

REFCT$(24)="BHEA" 

0004 

2324 

REFCT$(07)="AFYA" 

REFCT$(16)*"B0ZA" 

REFCTS(25)«"BIYA" 

OOEF 

2324 

REFCTI(08)»''AFYC" 

REFCTS(17)=“BEAA'* 

REFCT$(26)="DHDA" 

OEOA 

2324 

OEOA 

2324 

REM 

ENCOUNTER  FORM  CLINIC  PREFIX  TABLE  *•* 

OEOA 

2324 

REM 

CLINIC  #1 

CLINIC  #2 

OEOA 

2324 

CLINIC1.PFX$(0)*" 

;  CLIMIC2.PFX$(0)="  " 

0E1C 

2324 

CLIMIC1.PFXS(1)="B 

•  :  CLINIC2.PFXS(1)*"A" 

0E2E 

2324 

CLINIC1.PFX$(2)="0 

•  ;  CLIMIC2.PFX$(2>*"B'' 

0E40 

2324 

CLINIC1.PFX$(3)="F 

'  :  CLINIC2.PFX$(3)*"C'' 

0E52 

2324 

CLINIC1.PFX$(4)*"G 

■  ;  CLIMIC2.PFXS(4)*”D" 

0E64 

2324 

CLINIC1.PFX$(5)="S 

■  :  CLINIC2.PFXS(5)=‘'F“ 

0E76 

2324 

CLINIC2.PFX$(6)="S" 

0E7F 

2324 

0E7F 

2324 

REM 

ENCOUNTER  FORM  PROVIDER  TIME  TABLE  **• 

0E7F 

2324 

0E7F 

2324 

PROVIDER. TIME$(00) 

="000"  •  NO  TIME 

0E88 

2324 

PROVIDER. TIME$(01) 

="002"  •  2  MINUTES 

CE91 

2324 

PROVIDER. TIMES! 02) 

="005"  •  5  MINUTES 

nE9A 

2324 

PROVIDER. TIMES(03) 

="010"  •  10  MINUTES 

0EA3 

2324 

PROVIDER. TIMEt(04) 

="015"  •  15  MINUTES 

OEAC 

2324 

PROVIDER. TIMEt(05) 

="020"  '  20  MINUTES 

CEB5 

2324 

PROVIDER. TIMES(06) 

="030"  '  30  MINUTES 

OEBE 

2324 

PROVIDER. TIME$(07) 

="045"  '  45 

MINUTES 

0EC7 

2324 

PROVIDER. TIMES(08) 

="060"  ’  1 

HOUR 

OtOO 

2324 

PROVIDER. TlMEt(U9> 

="090"  ■  1 

HOURS/30  MINUTES 

OE09 

2324 

PROVIDER. TIMEFC.Gi 

="120"  ■  2 

HOURS 

PAGE  7 
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RACPCEM 

GENERAL  FORM  DESTRING/DECOOE  PROGRAM 


Offset 

Oata 

Soorce  Line 

0EE2 

2324 

PROVIDER. TIMES(11)= 

"150" 

‘  2  HOURS/30  MINUTES 

OEEB 

2324 

PR0VI0ER.1IMFS<I2>= 

"180" 

'  3  HOURS 

OEFA 

2324 

PROVIDER. TIME$(13)= 

"210" 

'  3  HaURS/30  MINUTES 

OEFD 

2324 

PROVIDER. TIMES(14): 

“240" 

■  4  HOURS 

0F06 

2324 

PROVIDER. TIHE$(15)= 

"270" 

■  4  HOURS/30  MINUTES 

OFOF 

2324 

PROVIDER. TIME$(16)= 

"300" 

'  5  HOURS 

0F18 

2324 

PROVIDER. TIMES(17)= 

"330" 

*  5  HOURS/30  MINUTES 

0F21 

2324 

PROVIDER. TIME$(18)= 

"360" 

>  6  HOURS 

0F2A 

2324 

PROVIDER. TIMES! 19): 

"390" 

'  6  HOURS/30  MINUTES 

0F33 

2324 

PROVIDER. TIMES{20>= 

"420" 

•  7  HOURS 

0F3C 

2324 

PROVIDER. riHES(21): 

"450" 

‘  7  HOURS/30  MINUTES 

0F45 

2324 

PROVIDER. TIMES(22): 

"480" 

■  8  HOURS 

0F4E 

2324 

0F4E 

2324 

REM  YES/NO  TABLE 

0F4E 

2324 

. .  YNS(1)="Y"  : 

YMS!2)="M"  :  YHS!3)="X" 

0F72 

2324 

0F72 

2324 

REM  TABLE  OF  OTHER 

COOES  ••• 

0F72 

2324 

SOCUOS(1)«'‘02000"  ; 

RHEUM$(01 )= 

"06002" 

OPTOMSf01)="03001" 

0F8O 

2324 

RHEUHS(02)= 

“06003* 

OPTQM$!02)»"03002" 

0F9F 

2324 

RHEUMS(03)= 

"06004" 

OPTOMS{03)»"03003" 

0FB1 

2324 

PSCOL$(Q1)*"04032“ 

RHEUMS<04)= 

"06005" 

OPTONS(04)>"03004" 

OFCC 

2324 

PSCOL$(02)*“04033« 

RHEUM$<05)»“06011" 

OPTOMS!05>*"03005" 

0FE7 

2324 

PSCOL$(03):‘'04034" 

RHEUMS(06)="06010" 

OPTOMS(06)="03006" 

1002 

2324 

PSCOL$(04)*"04026" 

RHEUM$(07)»"06007" 

OPTOMS!07)*"03007" 

1010 

2324 

PSCOLS(05)»“04031'' 

RHEUM$(08)»"06001" 

OPrOMS<08)*"03008" 

1038 

2324 

PSCOL$(06)»"04028'' 

RHEUMS<09)* 

"06006" 

OPTOMS!09)="03009" 

1053 

2324 

PSCOLS(07)="04029" 

RHEUMS(IO)* 

"06008" 

OPTOMSC10)="03010" 

106E 

2324 

PSCOL$(08):"04023« 

RHEUMS! 11)= 

"06009" 

0PT0MS!11)="03011" 

1089 

2324 

PSCOLS<09):"04025‘' 

OPTOMS{12)="03012" 

1098 

2324 

PSCOL$(10)="04024" 

OPTOMS(13)="03013" 

10AO 

2324 

PSCOLS<11)="04027" 

PSYCHS!01)= 

"04026" 

OPTOMS!14)="03014" 

10C8 

2324 

PSCOL$(12)=“04020" 

PSYCHS!02)= 

"04028" 

OPTOHS!15)="03015" 

10E3 

2324 

PSCOL$(13)="04030« 

PSYCMS!03)= 

"04029" 

OPTOMS!16)="03016" 

10FE 

2324 

PSCOL$(14)="04021" 

PSTCHS!04)» 

"04023" 

OPTOMS!17)="03017" 

1119 

2324 

PSCOL$(15):''04022» 

PSYCHS!05)= 

"04025" 

OPTOHS!18>="03018" 

1134 

2324 

PSCOL$(16):"04040'' 

PSYCHS!06)= 

"04024" 

OPTOMS!19)="03019" 

114F 

2324 

PSCOL${17)="04041" 

PSYCHS!07)= 

"04027" 

OPTOMS!20)="03020" 

116A 

2324 

PSCOL$<18):"04000" 

PSYCHS!08)= 

"04020" 

OPTOMS!21)="03021" 

1185 

2324 

PSCOL$<19)=‘'04001" 

PSYCHS!09)= 

"04030" 

1197 

2324 

PSCOLS(20):"04002" 

PSYCHS! 10)= 

"04021" 

nA9 

2324 

PSCOLS{21):“04003" 

PSYCHS! 11)= 

"04022" 

DIALYS!01)="06101" 

11C4 

2324 

PSCOLS(22)*"04004" 

PSYCHS!12)= 

"04040" 

0IALTS!02)="06102" 

11DF 

2324 

PSCOLl(23)="04005" 

PSYCHS! 13)= 

"04041" 

DIALYS!03>="06103" 

UFA 

2324 

PSCOLS( 24) ="04006" 

PSYCHS!14)= 

"04000" 

OIALYS!04)="06104" 

1215 

2324 

PSCOL$(25)="04007" 

PSYCHS! 15)= 

"04001" 

OIALYS!05)="06105" 

1230 

2324 

PSCOL$<26)="04008" 

PSTCHS!16)= 

"04002" 

OIALYS!06)="06106" 

124B 

2324 

PSCOL1(27)="04009" 

PSYCHS! 17)= 

"04003" 

DIALYS!07)="06107" 

1266 

2324 

PSCOLS(28)="04010" 

PSYCHS! 18)= 

"04004" 

DIALYS!08)="06108" 

1281 

2324 

PSCOLS(29)="04011" 

PSYCHS! 19)= 

"04005" 

DIALYS!09)="06109" 

129C 

2324 

PSCOLt(30)="04012" 

PSYCHS! 20)= 

"04006“ 

01ALYS!10)="06110" 

12B7 

2324 

PSCOLt(31)="04013" 

PSYCHS!21)= 

"04007" 

0IALYS!11)=»06111" 

1202 

2324 

PSCOLS(32)="04014" 

PSYCHS! 22)= 

"04008" 

D1ALYS!12)="06112" 

12ED 

2324 

PSCOLS(33)="04015" 

PSYCHS!23)= 

"04009" 

DIALYS!13)="06113" 

1308 

2324 

PSC0LS(34)="04016" 

PSYCH$!24)= 

"04010" 

01ALYS!14)="06114" 

PACE  8 
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Offset 

Data 

Source  Line 

1323 

2324 

PSYCH${ 25 >=“04011“ 

1335 

2324 

PSYCH$(26>«“04012“ 

1347 

2324 

PSYCH$<27>=“04013“ 

1359 

2324 

PSYCH$(28>=“04014“ 

1368 

2324 

PSYCH$(29>="04015“ 

1370 

2324 

PSYCH$<30)«"04016" 

138F 

2324 

1398 

2324 

PMYTHtcOI >="05001" 

13AA 

2324 

PHYTH$(02)«"05002" 

13BC 

2324 

PHYTH$(03)="05003" 

PSYASSd  >="02567“ 

1307 

2324 

PHYTH$<04)="05004" 

PSYASS{2>="02565“ 

13E9 

2324 

PHYTH$<05)="05005" 

PSYAS$(3>=“02566" 

1404 

2324 

PHYTH$(06)="05006" 

PSYASS(4 >="02568" 

141F 

2324 

PHYTH$(07)="0S007“ 

1431 

2324 

PHYTH$<081="0500a" 

NEUROS(01 >«»08000» 

144C 

2324 

PHYTH$(09)="05009" 

NEUROS(Q2>>“08001" 

1467 

2324 

PHYTH*<10)«"05010" 

NEURa$<03>="0a002" 

1482 

2324 

PHYTMV 11  >="05011" 

NEUROt(04>=“08003" 

1490 

2324 

PHYTH1<12)="05012" 

NEUROt<05>>«08004« 

1488 

2324 

PHYTH*<13)=“05013" 

NEUROS(06>="08005" 

1403 

2324 

PHYTHS<14)="05014" 

NEURO*(07>="08006“ 

UEE 

2324 

PHYTHS<15)="05015" 

NEURO$<08>="08007" 

1509 

2324 

PHYTH$(16>»"05016" 

NEURC«(09>*"08008" 

1524 

2324 

PHYTH$(17)»"05017" 

HEUROS<10>="08009" 

153F 

2324 

PHYTH$<18)="05018" 

NEURO$(11>="08010“ 

155A 

2324 

PHYTH$(19)="05019" 

MEUROS<12)="08011" 

1575 

2324 

NEURO$(13>="08012" 

1587 

2324 

1587 

2324 

ORTHOS<00)="  " 

ORTHOS(37>«"05537" 

15A2 

2324 

ORTHO$(01 >="05501" 

ORTHO$(3a>="05538“ 

1SB0 

2324 

ORTHO$(02)="03502" 

ORTHO$<39>="05539" 

1508 

2324 

ORrHO$<03)="05503" 

ORTHO$(40>="05540" 

15F3 

2324 

ORTHO$(  04  >="05504" 

0RTH0$<41 >="05541" 

160E 

2324 

ORTHOS(05>="05505" 

ORTHO$(42>*"05542" 

1629 

2324 

ORTHO$(06>="05506" 

0RTH0$<43 >="05543" 

1644 

2324 

ORTHO$(07>*"05507" 

ORTHO$(44>="05544" 

165F 

2324 

ORTHO$(08>»"05508" 

0RTH0S(45 >="05545“ 

167a 

2324 

08THO$(09>="05509" 

ORTHO$(46>="05546" 

1695 

2324 

ORTHO$(10)="05510" 

ORTH0$<47)="05547" 

1680 

2324 

ORTHO$(11>="05511" 

ORTHO$(48>="05548" 

16CB 

2324 

ORrHO$(12)="05512" 

0RTH0${49)="05549" 

16E6 

2324 

ORTHOS(13>="05513" 

ORTHO$(50>="05550" 

1701 

2324 

ORTHOt(14>="05514" 

0RTHO$(51 >="05551" 

171C 

2324 

ORTHO$(15>="05515" 

ORTHO$<52>="05552" 

'737 

2324 

ORrHO$(16>="05516" 

OfiTHCIS(53>="05553" 

1752 

2324 

ORTHO$(17>="05517" 

ORTH0S<54>="05554" 

1760 

2324 

ORTHO$(18)="05518" 

0RTH0$(55>="05555" 

1788 

2324 

ORTHOt(19>="OS519" 

ORTHO$(56>="05556" 

17A3 

2324 

ORTHOS<20)="05520" 

ORTHOS<57>="05557" 

17BE 

2324 

ORTHO$(21 >="05521" 

ORTHOS(58>="05558" 

1709 

2324 

ORTH01(22)=‘'05522" 

ORTHOS(59>="05559" 

17F4 

2324 

ORrHOt(23)="05523" 

ORTHO$(60>="05560" 

ISOF 

2324 

ORTHOt(24>="C'524" 

0RTH0$(61 >="05561" 

lEJA 

2324 

ORTHOt(25)="05525" 

ORTHOS(62)="05562" 
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DIALYS(15)«"06115" 

0IALY$(16)*“06t16" 

DIALYS(17)»“06n7“ 

0IALYS(18)*“06118'' 

D1ALY$(19)«="06119“ 

DIALY$(20>»"06120“ 

DIALY$(21)»“06121" 

0IALYS{22)="06122" 

0IALYS(23)="06123" 

DIALY$(24)=“06124" 

NEUROS(U)«“08013“ 

NEURO$(15)»“080U" 

NEUROS(16)*“08015“ 

NEUROSn7>«'‘08016'' 

MEUR0${18)*“08017" 

NEUR01<19>=“08018" 

NEUROS(20)*"08019“ 

NEUROS(21 )e«0SO2O" 

NEUROt(22)="08021" 

MEURO»(23)="08022'‘ 

NEURO$(24)="08023" 

NEURO*(25)='‘08O24" 

NEURC$(26)»"0802S'' 

NEURO*(27>*"08026" 

NEUROS(28)="08027“ 

NEURUS(29)="08028" 

ORTHOS(74)=''05574" 

ORTHOS(75)="05575" 

ORTHO$(76)*"05576'' 

ORTHO$<77)="05577" 

ORTHOS(78)=”05578” 

ORTHO$(79)="05579" 

ORTKOS(80 >*"05580" 

ORIHOSCBI >="05581“ 

ORTHO$C82>="05582" 

0RTHO$(83>="05S83" 

ORTHOJ(84>="05584" 

ORTHO$(85 >="05585" 

ORTHOS(86)="05586" 

ORTHC$(87>="05587" 

0RTH0$(88>="05588" 

ORTHOS(89>="05589" 

ORTHO$(90)="05590"  ^ 

ORTHOS(91 >="05591" 

ORTHOS(92>="05592" 

ORIHOi<93>="05593" 

DRTHO$(94>="05594" 

ORTHOS(95>="05595" 

ORTHOS(96>="05596" 

ORTHOt(97>="05597" 

ORrHOS(98)="05598" 

ORTHO$(99)="05599" 


RACPGEN 

GENERAL  FORM  OESTRING/OECGOE  PROGRAM 


Offset 

Data 

Source  Line 

1845 

2324 

ORTHO${26)=“05526“  :  ORTHCIl(63)«“05563«  ;  ORTHO«100)=“05600" 

1860 

2324 

ClfiTHO$(27)="05527"  :  ORTHO$(64)=''05564"  :  0RTHOl(101)»"05601“ 

187B 

2324 

ORTMO$(28)«"05528"  :  ORTHOS{65)«“05565“  :  ORTHO$(102)»“05602“ 

1896 

2324 

0RTHO$(29)*“05529"  ;  0RTHO$(66)=“05566"  :  0RTHO$<103)*"05603" 

18B1 

2324 

ORTHO${30)*«05530"  :  ORTHO$<67)»'>05567“  ;  ORTHOSn04)«“05604“ 

18CC 

2324 

ORTHO$(31)="05531"  :  ORTHOS<68)««0556a“  :  ORTHO$(105)*“05605“ 

18E7 

2324 

ORTHO$(32)*«05532"  :  ORTHO$(69)=«05569“  :  ORTH01(106)*“05606" 

1902 

2324 

0RTHO$(33)»"05533"  :  ORTHO$<70)»"05570"  ;  ORTHOS(107)=“05607" 

1910 

2324 

ORTMO$(34)="05534“  :  OfiTHOS<71 )»«05571« 

192F 

2324 

ORTHO${35)=''05535"  :  ORTHO$<72)="05572“ 

1941 

2324 

ORTHO${36)="05536"  ;  ORTHO4<73)»''05573“ 

1953 

2324 

1953 

2324 

REN 

1953 

2324 

PMJM=VAL(PCMIDS)/10 

1965 

2326 

REM 

LENGTH  OF  STRING  RECEIVED  FROM  THE  CNR.... 

1965 

2326 

HEADER  >  21 

196C 

2328 

RESPONSE:  NRESPTPNUM) 

197A 

232A 

RECOROLENGTH  :  HEADER  +  RESPONSE 

1985 

232C 

1985 

232C 

N.PROC  a  PROCN(PNUM)  •  NUMBER  OF  PROCEDURES  FOR  THIS  FORM 

1993 

232E 

N.DIAC.COLa4  •  NUMBER  OF  DX  COLUMNS  OH  THIS  FORM 

199A 

2330 

IF  CC4(PNUM)a0  THEN  N.DIAG.COLaN.OIAG. COL-1 

19S3 

2330 

IF  CC3(PNUM)a0  THEN  N.OIAG.COLaN.OtAG.COL-1 

19CC 

2330 

IF  CC2(PNUM]«0  THEN  N.DIAG.COLaN.OIAG. COL-1 

19E5 

2330 

19E5 

2330 

OATFILS  a  "VISIT.OAT"  'FILE  TO  BE  INPUT  TO  FOCUS 

19EE 

2334 

BTIMESaTIMES  'SCAN  START  TIME 

19F7 

2338 

19F7 

2338 

REM 

ENCOUNTER  FORM  PROCEDURE  TABLE  *** 

19F7 

2338 

F.NAME$="RACPROC."  ♦  PCMIOS 

1A05 

233C 

1A05 

233C 

OPEN  F. NAMES  FOR  INPUT  AS  #3 

1A16 

233C 

FOR  1600=0  TO  125 

1A1C 

233C 

INPUT  «,PROCE0S<I600) 

1A34 

233E 

IF  PROCEDS(I600)="2ZZ22"  THEN  GOTO  4 

1AS0 

233E 

NEXT  1600 

1A5F 

233E 

4 

CLOSE  « 

1A66 

233E 

1A66 

233E 

REM 

•••  ENCOUNTER  FORM  DIAGNOSIS  TABLE 

1A66 

233E 

F.NAME$="RACOIAG."  +  PCMIOS 

1A74 

233E 

1A74 

233E 

OPEN  F. NAMES  FOR  INPUT  AS  «3 

1A85 

233E 

FOR  1600  a  0  TO  225 

USB 

233E 

INPUT  «3,DIAGN.TABS(I600) 

UA3 

233E 

IF  DIAGN.TABS(I600)="ZZZZZ"  THEN  GOTO  6 

UBF 

233E 

NEXT  1600 

1ACF 

233E 

6 

CLOSE  « 

1A06 

233E 

1A06 

233E 

REM 

INCLUDE;  'UCACAMP.OPT'  INCLUDE  THE  OUTP  UCA  VALIDATE  TABLE 

1A06 

233E 

REH 

INCLUDE:  'UCACAMP.  IPT  •  INCLUDE  THE  INP  UCA  VALIDATE  TABLE 

1A06 

233E 

1AD6 

233E 

REM 

SPACE 
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Offset  Data  Soorce  Line 

1A06  233E  GOSUB  1000  'MAKE  SURE  THEY  ARE  LOGGED  ON 

1A0B  233E  CLS 

1AOF  233E  GOSUB  7000  'PRINT  SCREEN  HEADING 

IAEA  233E 

IAEA  233E  REM 

IAEA  233E  REM  ***•  OPEN  FILE  TO  CONTAIN  SCANNED  DATA  *•** 

IAEA  233E  REM 

IAEA  233E  REM 

IAEA  233E  OPEN  DATFILS  FOR  APPEND  AS  «1 

1AF6  233E 

1AF6  233E  REM 

1AF6  233E  REM 

1AF6  233E  REM 

1AF6  233E 

1B01  233E 

1B0B  233E 

1B17  23A0 

1B1E  23A0 

1B33  23A0 

1BA9  23A0 

1BA9  23A0  REM 

iaA9  23A0  REM 

1BA9  23A0  REM 

1BA9  23A0  REM 

1BA9  23A0 

IBAE  23A0 

1B6a  23AA 

1B68  23AA  REM  START  SCANNER  (SI) 

1B68  23AA  CNTRLOPT  =  1  ;GOSUB  9010 

1B7A  23A6  IF  ERRHSGS  >  "  "  THEN  LPRINT  ERRMSGS  :  GOTO  30000 

1B8E  23A6 

1B8E  23A6  LOCATE  22,25:PRINT  "PRESS  'ESC  TO  TERMINATE  SCANNING  " 

18A3  23A6  REA0TYPE=3  'FIRST  TIME  IN..  SCANNER  IS  STARTED.. 

1BAA  2348 

1BAA  23A8  REM 

1BAA  2348  REM  •••  SET  SCAM  SHEET  CALL 

1BAA  2348  REM 

1BAA  23A8  REM 

1BAA  2348 

18AA  2348  10  REM  -  RETURN  POINT  TO  READ  NEXT  SHEET 

1BAB  2348 

1BAB  2348  AS= INKEYS 

'884  234C  IF  A$-CHRS(27)  THEN  GOTO  25000 

18CA  234C 

18CA  234C  GOSUB  9020  'SCAM  SUBROUTINE  -  GET  A  RECORD 

IdCF  234C  IF  MID$(ERRSTAT$,14,3)="415"  THEN  GOTO  25000 

1BEB  2350 

1BEB  2350  TEXTS=""  'CLEAR  THE  INPUT  AREA 

1BF4  2350  GOSUB  8000  'DECODE  HEADER 

lbF9  2350  GOSUB  8050  'CHECK  FOR  END  OF  JOB/EHO  OF  BATCH 

1BFE  2350  GOSUB  8200  'DECODE  THE  RESPONSE  POSITIONS 

IC03  2350  LITHOS  =>  MIOS(1EXT$,22,8) 

'C’5  2354  GOSUB  8070  'ClircK  FOR  SCAMMER  ERRORS 

ICIA  2354  CCSU8  8100  'PRINT  THE  DATA  ON  THE  SCREEN 


COMMUNICATIONS  SETUP 


PROTOCOL 
GOSUB  9001 

IF  ERRMSGS  >  "  "  THEN  LPRINT  ERRMSGS  ;  GOTO  30000 


CLEAR  AND  DISPLAY  PROGRAM  SCREEN  ***' 


LPRINT  CHRSdS); 

WIDTH  "LPT1;",160 

PAGE  >  0  ;  GOSUB  7100  'LINE  PRINTER  HEADING 
COLOR  14 

LOCATE  11,26  ;  PRINT  "BASE  ENCOUNTER  FORM  " 

COLOR  FORE, BACK, BORD 
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IBM  Personal 

Computer  BASIC  Compiler  VI. CO 

’  1C1F 

2354 

1C1F 

2354 

REM  SIHCLUOE:  'RACREAO.MOO*  INCLUDE  THE  READ  FORM  REFORHAT/EDIT 

MOO 

k  1C1F 

2354 

REM 

»**«** 

F  1C1F 

2354 

REM 

AMBULATORY  CARE  INFORMATION  SYSTEM  10  MAR  87 

**** 

1  1C1F 

2354 

REM 

*•**  0  R  BOLLING 

*«** 

1  1C1F 

2354 

REM 

••••  module  name  ;  RACREAO.MOO 

**** 

1  1C1F 

2354 

REM 

SCANNER  PROGRAM  «  ;  GENERAL  FORM 

1  1C1F 

2354 

REM 

L  1C1F 

2354 

REM 

*•”*  PURPOSE  :  REFORMAT/EOIT  THE  FORM 

P  1C1F 

2354 

REM 

***• 

**** 

REM 

***** 

1 

2354 

REM 

***•  RESERVED  LINE  NUMBERS  100-199 

*••• 

**  ** 

1  1C1F 

2354 

■  1C1F 

2354 

N.ERR  ‘0  'COUNTS  THE  NUMBER  OF  ERRORS 

■  1C26 

2356 

F  1C26 

2356 

REN 

•••  LITHO  CODE  DONE  IN  BAS  PROGRAM 

1  1C26 

2356 

REM 

•**  CLINIC  ID  (PREFIX  ♦  CODE)  ••• 

■  1C26 

2356 

100 

CL1.COOS:CLIOEFS(PNUM)  'DEFAULT  CLINIC  CODE 

1  1C38 

235A 

■  1C38 

235A 

REM 

...  CLINIC  CODE  UHEN  SINGLE  BUBBLED  ... 

L  1C38 

235A 

IF  MI0$<TEXT$,34,1)»"  "  THEN  102 

B  KSO 

235A 

X=VAL<MI0$<TEXT$,34,1)) 

■  1C66 

235C 

1 

B  1C66 

235C 

'  SET  PHTH=1  IF  PHYS  THER  FORM  MEEDS  MULTIPLE  RECORD  OUTPUT 

■  1C66 

235C 

IF  LEFT$(PGHI0$,2)=“68"  AND  X=2  THEM  PHTH=1  ELSE  PHTH=0 

B  1CAO 

235  E 

i 

B  1CAO 

235  E 

X=(X-1)*4»1  'CALCULATE  OFFSET 

B 

235E 

CL1 .COO$=MIDS(CLIBUB$(PNUM).X,4) 

F  1CCC 

235E 

GOTO  104 

B  1COO 

235E 

B  1CD0 

235E 

REM 

...  CLINIC  CODE  WHEN  HAND  COOEO  ... 

B  1CDO 

235E 

102 

IF  MI0$(TEXT$,30,4)="  "  THEN  104 

B  1CE8 

235E 

CK.X=VAL(MI01(TEXTS,30,1)) 

B  1CFE 

2360 

CK.COO$=MIOS<TEXT$,31,3) 

B  1010 

2364 

REM 

GOSU8  5500  'OUTP  UCA  CODE  CHECK 

B  1010 

2364 

REN 

IF  RT.5500  »  0  THEN  GOTO  102 

B  1010 

2364 

REM 

N.ERR  :  N.ERR  *  1 

B  1010 

2364 

REM 

EO.MSGt(N.ERR)="INVALID  CLINIC  CODE" 

B  1010 

2364 

B  1010 

2364 

CL1.C00S=CLINIC1.PFX$(CK.X)  +  CK.COOS  'HAND  CODED 

B  1028 

2364 

1 

B  1028 

2364 

REM 

VISIT  DATE 

B  1028 

2364 

104 

CMt=:MIDS(0ATE$,1,2)  'CURRENT  MONTH 

B  103A 

2368 

YR$=MID$<0ATE$,9,2)  'CURRENT  YEAR 

B  1DAC 

236C 

XS=HIDS(TEXT$,35,4)  'MONTH  ANO  DAY 

1 

B  105E 

2370 

IF  LEFT$(XS,2)<=CH$  THEM  105  'OK,  USE  THIS  YEAR 

B  1073 

2370 

YRS=R1GHTS(STR$(VAL(YRS)-1),2)  'USE  LAST  YEAR 

i 

F  1093 

2370 

105 

VIOATES=YR$+X$ 

B  10A1 

2374 

D1S=MI0$(Xt,3,1) 

B  1DB3 

2378 

02$=MID$(Xt,4,1) 

B  1DCS 

237C 

IF  on="  "  ANO  0250"  "  THEN  RT. 5000=2  :  GOTO  106 

B  1DF3 

237E 

IF  OISo"  "  ANO  02S="  "  THEM  RT. 5000=2  :  GOTO  106 

I 

23  7E 

'EDIT  VISIT  DATE 

i 

RACPGEM 

GENERAL  FORM  DESTRING/DECOOE  PROGRAM 


r 


OffsRt  Data  Source  Line 


1E21 

237E 

CK.5000$=V10ATE$ 

1E2A 

2332 

GOSUB  5000  ‘DATE  CHECK 

1E2F 

2382 

IF  RT. 5000=0  THEN  GOTO  107 

1E3E 

2382 

106 

H.ERR=M.ERR+1 

1E46 

2382 

EO.MSGt<N.£RR)=''VISIT  DATE"  ♦  OATEERRS<RT.5O0O) 

1E6C 

2382 

1E6C 

2382 

REM 

PRIMARY  PROVIDER  •** 

1E6C 

2382 

107 

PPROV.PFX$=MIOS{TEXT$,39,1) 

1E7E 

2386 

PPROV . NUH$=M ID${TEXT$,40,4) 

1E9a 

238A 

1E90 

238A 

REN 

PATIENT  SSN  *** 

1E90 

238A 

108 

SSNS  =  H1D$<TEXT$,44,9) 

1EA2 

238E 

1EA2 

238E 

REM 

FAMILY  MEMBER  PREF  •** 

1EA2 

238E 

110 

FMEMP$=MID$<TEXT$,53,2) 

1EB4 

2392 

1ES4 

2392 

REM 

*•*  FORM  NUMBER  *** 

1EB4 

2392 

FRHNl=LEFT$<PGMI0i,2) 

1EC3 

2396 

16C3 

2396 

REM 

»*»  VISIT  COUNT  •** 

1EC3 

2396 

112 

VCNT$='‘1" 

1ECC 

239A 

TEHP$=MID$(TEXT$,55,1) 

1E0E 

239E 

IF  TEMP$=‘'1“  THEN  VCMTS="0" 

1EF5 

239E 

IF  TEHP$>"1"  THEN  VCNT$=TEMP$ 

1F0C 

239E 

1F0C 

239E 

REM 

PRIMARY  PROVIDER  TIME  *** 

IfOC 

239E 

113 

X=VAL(MID$(TEXT$,56,2)) 

1F22 

239E 

PPROV. TIM$=PROVIOER.TIMES<X) 

1F34 

23A2 

1F34 

23A2 

REM 

•**  SECONDARY  PROVIDER  *** 

lf34 

23a2 

SPROV.PFX$=MIO$(TEXTS,58,1) 

1F46 

23a6 

SPROV.NUM$=HIOS(TEXT$,59,4) 

1F58 

23AA 

IF  SPROV.PFXS+SPROV.NUMS  =  "  "  THEN  SPBL=1 

ELSE  SPBL=I 

1F7D 

23AC 

IF  SPROV.PFXS="  "  ANO  SPROV . NUMS<>"  "  THEM 

114 

1FA3 

23AC 

IF  SPROV. PFXSo"  ••  AND  SPROV.NUNS="  "  THEN 

114 

1FC9 

23AC 

GOTO  115 

IFCD 

23AC 

1FCD 

23AC 

114 

N.ERR  =  N.ERR  ♦  1 

’F05 

23AC 

ED.MSG$(N.ERR)="PROV  2  CODE  MISSING  PREFIX  OR 

NUMBER" 

iFE9 

23AC 

IFE9 

23AC 

1FE9 

23AC 

REM 

**•  SECONDARY  PROVIDER  TIME  *** 

1FE9 

23AC 

115 

X=VAL(MID»(TEXT$,63,2)) 

1FFF 

23AC 

SPROV.TIM$=PROVIDER.TIME$(X) 

2011 

23B0 

REM  IS  THERE  A  TIME  ANO  MO  SEC  PROV  COOED? 

2011 

23B0 

IF  SPROV.TIMS  <>  "000"  AND  SPBL  =  1  THEM  116 

•GO  IF  YES 

2034 

2380 

REM  IS  THERE  NO  TIME  ANO  A  SEC  PROV  COOED? 

2034 

23B0 

IF  SPROV.TIMS  =  "000"  AND  SPBL  =  0  THEM  117 

•GO  IF  YES 

2057 

23S0 

GOTO  118 

'05B 

23B0 

2058 

23S0 

116 

1  N.ERR  =  N.ERR  *•  1 

2063 

2310 

ED.MSr.tCM.ERR!  =  '’TIM£  COOED  WITH  NO  SEC  PROV  COOED" 

2077 

2380 

coir  118 
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207B 

23B0 

117 

N.ERR  >  N.ERR  +  1 

2083 

23B0 

ED.MSG$(N.ERR)="NO  PROV  2  TIME" 

2097 

23B0 

2097 

23B0 

REM 

REASON  FOR  SECONDARY  PROVIDER 

2097 

23B0 

118 

SPROV . REA$=M IDS(TEXT$,65,1) 

20A9 

23B4 

REM  IS  THERE  A  REASON  AND  NO  SEC  PROV  CQOEO? 

20A9 

23B4 

IF  SPROV. REAS  <>  "  "  ANO  SP8L  «  1  THEN  119  'GO  If  YES 

20CC 

23B4 

REM  IS  THERE  NO  REASON  AND  A  SEC  PROV  COOED? 

20CC 

2384 

IF  SPROV. REAS  =  "  ■■  ANO  SPBL  :  0  THEN  120  'GO  IF  YES 

20EF 

2384 

GOTO  122 

20F3 

23B4 

20F3 

23B4 

119 

N.ERR  =  N.ERR  *  1 

20FB 

2384 

ED.MSGS(N.ERR)="REASON  COOED  WITH  NO  SEC  PROV  COOED” 

210F 

2384 

GOTO  122 

2113 

2384 

2113 

23B4 

120 

N.ERR  ”  N.ERR  *  1 

211B 

23B4 

EO.MSGS(N.ERR)=“NO  PROV  2  REASON” 

212F 

2384 

212F 

2384 

REM 

IF  NOT  SCHEDULED  »*« 

212F 

2384 

122 

X»VAL<HID$(TEXT$,66,1)) 

2U5 

2384 

NOTSC$=RIGHT$(STR$<Xf1),1)  'DEFAULT  IS  1 

2159 

2388 

2159 

2388 

REM 

IF  NOT  CLINIC 

2159 

2388 

124 

X=VAL<MIDS(TEXT$,67,1)) 

216F 

2388 

MOTCL$=RIGHT$(STR$(X*1),1J  'DEFAULT  IS  1 

2183 

23BC 

2183 

23BC 

REM 

REFERRAL  CODE 

2183 

23BC 

126 

CX.X=VAL(MID$(TEXT$,68, 1)) 

2199 

23BC 

CK.COOS=MIO$<TEXTS,69,3) 

21AB 

23BC 

REM 

IF  CK.X=0  ANO  CK.COOS="  "  THEN  GOTO  142  'MAY  NOT  BE  COOED 

21AB 

23BC 

REM 

GOSUB  5600  'VALIDATE  INP  UCA  CODE 

21AB 

23BC 

REM 

IF  RT.5600  =>  0  THEN  GOTO  142 

21AB 

23BC 

REM 

N.ERR  :  N.ERR  *  1 

21AB 

238C 

REM 

ED.MSGS(N.ERR)="INVALID  REFERRAL  COOE" 

21Ae 

238C 

21AB 

23BC 

128 

REF . PFXS=CL I N I C2 . PFXSTCX. X ) 

21BO 

23C0 

REF.COO$=CX.COO$ 

21C6 

23C4 

21 C6 

23C4 

REM 

...  OTHER  REFERRAL  COOES  (FORM  680  -PHYS  THER  ONLY) 

21C6 

23C4 

IF  FRMN$<>"68"  then  129  '00  ONLY  FOR  680 

21DA 

23C4 

X=VAL(MI0S(TEXTS,76,2)) 

21EA 

23C4 

IF  X=0  THEN  129  'NO  COOE  BUBBLED 

21F5 

23C4 

REF .PFX1=MIDS(REFC0$(X) , 1,1) 

220F 

23C4 

REF.C00$=MI0$(REFC0$(X),2,3) 

222A 

23C4 

222A 

23C4 

129 

IF  FRHMS<>"6S"  THEN  130  '00  ONLY  FOR  650 

2238 

23C4 

X=VAL(MIDS(TEXTS,76,2)) 

224E 

23C4 

IF  X=0  THEN  130  'NO  COOE  BUBBLED 

2259 

23C4 

REF.PFXS=MIDS(REFCT$(X),1,1) 

2273 

23C4 

REF.COOS=MIOS(REFCTS(X),2,3) 

228E 

23C4 

228E 

23C4 

REM 

***  JOB  RELATED  VISIT  »** 

228E 

23C4 

130 

RELAT.VISS="N" 

2297 

23C8 

If  MICS(TEXTI,72,1)="1"  THEN  RELAT.VIS$="Y" 
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22B8 

23C8 

2288 

23C8 

REM 

•••  MIL  ONLY  DUTY  ••• 

2288 

23C8 

132 

M1L0UT$=MIDS{TEXT$,73,1) 

22CA 

23CC 

22CA 

23CC 

REM 

**•  MIL  ONLY  OTRS 

22CA 

23CC 

134 

MILQTR$=MIDS(TEXT$,74,1) 

22DC 

2300 

220C 

2300 

REM 

MIL  ONLY  PROF  »•* 

220C 

2300 

136 

MILPROS=MI01<TEXT$, 75 , 1 ) 

22EE 

2304 

22EE 

2304 

REM 

•••  NOT  AVAILABLE 

22EE 

2304 

138 

NAVA I L$=M I0S<  TEXTS ,76,1) 

2300 

2308 

2300 

2308 

REM 

**•  SPEC  PREASS  I GNEO  CLINIC  •*» 

2300 

2308 

140 

INP.STQ$=MI0S<TEXT$,81,12) 

2312 

230C 

GOSUS  5700  'CONVERT  ARRAY 

2317 

230C 

SPE.8UF$=8Uf  .STOS  'UP  TO  12  TWO  DIGIT  CODES 

2320 

23E4 

2320 

23E4 

REM 

•**  PROVIDER  2  AOOL  PROC  1 

2320 

23E4 

144 

PR2PRC1$=''M" 

2329 

23E8 

If  MI0$<TEXT$,93,1)='’1''  THEN  PR2PRC1S«“Y« 

234A 

23E8 

IF  PR2PRC1$*"r“  AND  SP8L=1  THEN  145 

2360 

23E8 

GOTO  146 

2371 

23E8 

2371 

23E8 

145 

N.ERR  s  N.ERR  *  1 

2379 

23E8 

ED.MSGX{N.ERR)="AOOL  PROC  CODE  FOR  SEC  PROV  BUT  NO  SEC  PROV 

COOED" 

2380 

23E8 

2380 

23E8 

REM 

•**  ADDITIONAL  PROCEDURE  1  »** 

2380 

2388 

146 

AD0P1$=MIDS<TEXT$,94,5) 

239F 

23EC 

239F 

23EC 

REM 

provider  2  AOOL  PROC  2  **• 

23?F 

23eC 

148 

PR2PRC2$="M" 

23A8 

23F0 

IF  MI0$(TEXT$,99,1)="1''  THEN  PR2PRC2$="Y" 

23C9 

23  fO 

IF  PR2PRC2S="r"  AND  SPBL=1  THEN  149 

23tC 

23  FO 

GOTO  150 

23F0 

23f0 

23f0 

23F0 

149 

N.ERR  =  N.ERR  +  1 

23f8 

23f0 

ED.MSG$(N.ERR)="A00L  PROC  CODE  FOR  SEC  PROV  BUT  NO  SEC  PROV 

CTOED" 

240C 

23F0 

240C 

23F0 

REM 

•**  ADDITIONAL  PROCEDURE  2  •••• 

?40C 

23F0 

150 

A0DP2$=HID$(TEXT$, 100,5) 

24  IE 

23F4 

241E 

23F4 

REM 

**♦  ADMITTED  *** 

24  IE 

23F4 

ADMIT$="N" 

2427 

23F8 

IF  MID$(TEXT$,105,1)="1"  THEN  AOMIT$s"Y" 

- 

2448 

23f8 

2448 

23F8 

REM 

***  EDIT  FOR  MIL  ONLY  BOX  »»* 

2443 

23f8 

If  ADMITS='‘N"  THEN  155  'OX,  NO  NEED  TO  CHECK 

2455 

23F8 

IF  M1L0UTS="  "  AND  MILOTR$="  "  THEM  155  'OX 

^479 

23f8 

2479 

23F8 

152 

REM  ...  ERROR  DUTY,  QTRS  AND  ADMITTED  CANNOT  ALL  EE  CODED 

24  7A 

23Fe 

N.ERR  =  N.ERR  ♦  1 

2.52 

23F8 

ED.“  'TfN.r''0="C'JTY  OR  OTRS  CANNOT  BE  COOED  WITH  ADMITTED" 

2.v;6 

23F3 
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2696  23f8  REM  UNLISTED  PRIMARY  DX 

2696  23F8  155  X=VAL(MID$(TEXT$, 106, 1 )) 

26AC  23F8  IF  X=0  THEM  PRIMOX$«““ 

26C0  23FC  IF  X=1  THEN  PRIMOX$»"V" 

26D6  23FC  IF  X=2  THEM  PRIMOX$="S" 

26E8  23FC  DXTHP$=MID$<TEXTS, 107,5) 

26FA  2600  IF  DXTMP$»"  “  THEN  GOTO  158 

250C  2600 

2S0C  2600  REM  REMOVE  LEADING  BLANKS 

250C  2600  156  IF  LEFTt(0XTMP$,1)=«  “  THEN  DXTHP$s:RIGMT$(DXTMPl,6)*“  “:GOTO  156 

2S3B  2600 

253B  2600  158  LASTC$-RIGHTS(DXTMPS,1)  'GET  LAST  CHAR 

256A  2606  IF  LASTCSo"  «  AND  LASTCS<>"0"  THEN  PRIH0X$='‘“  'REMOVE  V  OR  S 

2576  2606  PRIM0X$»LEFTS(PRIM0X$+0XTMPS,5)  'GET  5  CHAR  ONLY 

2588  2606 

2588  2606  REM  •**  UNLISTED  SECONDARY  DX  **• 

2588  2606  160  X«VAL<MI0$<TEXT$, 112, 1 )) 

259E  2606  IF  X«0  THEM  SECOXS"'"* 

2582  2608  IF  X*1  THEM  SECDXS="V“ 

25C6  2608  IF  X»2  THEN  SEC0Xt=“S" 

250A  2608  DXTMP$«MI0$<TEXTS,113,5) 

25EC  2608  IF  OXTMPS*"  "  THEN  GOTO  166 

25FE  2608 

25FE  2608  REN  REMOVE  LEADING  BLANKS 

25FE  2608  162  IF  LEFT$<DXTMP$,1)*''  "  THEM  0XTMP$=RIGHT$(0XTMP$,6)*«  «:GOTO  162 

2620  2608 

2620  2608  166  LASTC$=RIGHT$<DXTMP$, 1 )  'GET  LAST  CHAR 

263C  2608  IF  LASTCSo"  "  AND  LASTC$<>‘'0"  THEM  SEC0X$=""  'REMOVE  V  OR  S 

2668  2608  SEC0X$=LEFT$(SEC0X$+0XTMP$,5)  'GET  5  CHAR  ONLY 

267A  2608 

267A  2608  REM  FOLLOW  UP/RULE  OUT  •*» 

267A  2608  166  FU.RO$=MIDS(TEXT$, 1 18, 1 ) 

268C  260C 

268C  260C  REM  EVALUATION/SERV/PRCC  PROV  1  ••• 

268c  260C  168  IMP.STOS=MIOS(TEXT$, 1 19,N.PROC) 

269F  260C  ESP.BUFISs"" 

26A8  2610  N.STO=1 

26AF  2612 

26AF  2612  170  X.STO=INSTR(N.STO, INP.STO$,"1") 

26C1  2616  IF  X.STO=0  THE.'J  GOTO  172  'THATS  ALL 

2600  2616  M.STO*X.STO  ♦  1  'NEXT  STARTING  POINT 

2608  2616  ESP.BUFISsESP.BUFIS  ♦  PROCEDSCX.STO)  'AOO  CODE  TO  BUFFER  BY  FIVES 

26E0  2616  IF  N.STO  <=  LEN(INP.STOS)  THEN  GOTO  170 

2700  2616 

2700  2616  REM  EVALUATION/SERV/PROC  PROV  2 

2700  2616  172  IMP.SIO$=MIOS<TEXTS, 119+M.PROC,M.PROC) 

2717  2616  ESP.BUF2$="» 

2720  2618  N.STO=1 

2727  2618 

2727  2618  176  X.STO=INSTR(N.STO, INP.STOS,"1") 

2739  2618  IF  X.ST0=0  THEM  GOTO  176  'THATS  ALL 

2768  2618  IF  SPROV.NUMS  =  "  "  THEN  175  'NEED  SEC  PROV  COOED 

2756  2618  N.STO=X.STO  ♦  1  'NEXT  STARTING  POINT 

275E  2618  ESP.8UF2S=ESP.BUF2S  ♦  PROCEDS(X.SIO)  'ADO  CODE  TO  BUFFER  BY  FIVES 
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2773 

2418 

IF  N.STO  <s  LENdNP.STOS)  THEN  GOTO  174 

2786 

2418 

GOTO  176 

278A 

2418 

278A 

2418 

175 

M.ERR  »  N.ERR  *  1 

2792 

2418 

ED.MSGS(N.ERR)=«PROC  CODE  FOR  SEC  PROV  8UT  MO  SEC  PROV  COOED" 

27A6 

2418 

27A6 

2418 

176 

T.POS  =  119  ♦  2*N.PROC 

2784 

241A 

27B4 

241 A 

REM 

•**  OTHER  COOES  *** 

2784 

241A 

IF  NOTHCPHUMI^O  THEN  184  'SKIP  THIS  IF  NO  COOES 

27C5 

241A 

178 

INP.STOS:HIOS(TEXT$,T-POS,HOTH(PNUH)) 

27DF 

241A 

OTH.BUF$»"« 

27Ea 

241E 

N.STO=1 

Z7EF 

241E 

27EF 

241E 

180 

X.ST0=IHSTR<H.ST0,IHP.ST0$,“1") 

2801 

241E 

IF  X.STO^O  THEN  GOTO  182  'THATS  ALL 

2810 

241E 

N.STOX.STO  +  1  ’NEXT  STARTING  POINT 

2818 

241E 

IF  PNUM  *54  THEN  OXS*OIALr$(X.STO)  'NEPHROLOGY/DIALYSIS  COOES 

2835 

2422 

IF  PNUM  *56  THEN  OXS*NEUROS(X.STO)  'NEUROSURGERY  COOES 

2852 

2422 

IF  PHUM  *62  THEN  OXS^OPTOMSfX.STO)  'OPTOMETRY  COOES 

286F 

2422 

IF  PNUM  *63  THEM  OX$*ORTHOS(X.STO)  'ORTHO  APPL  COOES 

288C 

2422 

IF  PNUM  *68  THEM  0X$*PHYTHS<X.S70)  'PHYSICAL  THERAPY  COOES 

28A9 

2422 

IF  PNUM  *73  THEN  OXS*PSYCH$(X.STO)  'PSYCHIATRY  COOES 

28C6 

2422 

IF  PNUM  *74  THEN  OX$*PSCOL$<X.STO)  'PSYCHOLOGY  COOES 

28E3 

2422 

IF  PNUM  =77  THEM  OX$*RMEUM$(X.STO)  'RHEUMATOLOGY  COOES 

2900 

2422 

IF  PNUM  *78  THEM  OX$*SOCUO$<X,STO)  'SOCIAL  WORK  COOES 

2910 

2422 

OTH.8UF$=OTH.8UF$  ♦  OXS  'ADD  C»E  TO  BUFFER  BY  FIVES 

2929 

2422 

IF  N.STO  <=  LENdNP.STOS)  THEM  GOTO  180 

293C 

2422 

293C 

2422 

182 

T.POS  *  T.POS  ♦  NOTH(PMUH) 

2946 

2422 

184 

REM 

294F 

2422 

294  F 

2422 

REM 

•*»  PRIMARY  OX  ••• 

294  F 

2422 

REM 

*  IF  OTHER  PRIM  OX  IS  CODED  THEM  SKIP  THIS  SECTION  * 

294  F 

2422 

186 

IF  PRIMOXSo"  “  THEN  GOTO  192 

2961 

2422 

X.POS»T.POS  'STARTING  POSITION 

2968 

2424 

C1SIZ=CCUPNUH):  C3SI2=CC3<PNUM)  'NO.  OF  ITEMS  IN  EACH  COL 

2984 

2428 

C2SIZ=CC2(PNUH):  C4SIZ=CC4(PNUH) 

29A0 

242C 

GOSUB  5801/  'GET  POSITION 

29A5 

242C 

IF  X.FIN=0  THEN  GOTO  188 

2984 

242E 

IF  RT. 5800=0  THEM  GOTO  190 

29C3 

2430 

N.ERR=M.ERR  ♦  1 

29C0 

2430 

ED.HSGS(N.ERR)="PRIMARr  OX  HAS  MULTIPLE  COOES" 

290  F 

2430 

GOTO  190 

29E3 

2430 

•' 

29E3 

2430 

188 

N.ERR=N.ERR  *  1 

29E8 

2430 

EO.MSGt(N.ERR)="PRIMARY  OX  NOT  COOED" 

29FF 

2430 

29FF 

2430 

190 

PR  I M0X$=D 1 ACN . TABSIX . F I N ) 

2A11 

2430 

2A11 

2430 

192 

T.POS  =  T.POS  <•  2  *  N.OIAG.COL 

2A20 

2430 

NOX  =  CC1<PNUM)*CC2(PNUM)*CC3CPNUM)tCC4(PHUM)*NS0XCPNUM) 

2A3F 

2432 

2A5F 

2432 

REM 

»*■*  SCCO'.'"  '--r  .X  *** 

I 
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2A3F  2432  INP.STOS^MIOSITEXTS.T.POS.NOX) 

2A53  2432  0X2.8UFS="" 

2A5C  2436  N.STO=1 

2A63  2436 

2A63  2436  194 

2A75  2436 

2A84  2436 

2A8C  2436 

2AA1  2436 

2AB4  2436  195 

2AC6  2436 


2A02 

2436 

2AD2 

2436 

196 

T.POS  a  T.POS  ♦  NOX 

2AOD 

2436 

2AD0 

2436 

IF  PGMIDS  <>  "740"  THEM  197 

■SKIP  IF  NOT  PSYCHOLOGY 

2AEB 

2436 

REM 

PSYCHOMETRIC  ASSESSMENTS 

2AEB 

2436 

lNP.STO$aMIO$<TEXTS,T.POS,4) 

2AFE 

2436 

GOSUB  5700  'CONVERT  ARRAY 

2B03 

2436 

PSYCHOSaBUF.STOS  'UP 

TO  4  TWO  DIGIT  CODES 

2B0C 

243A 

T.POS  a  T.POS  ♦  4 

2B17 

243A 

2817  243A  197 

2825  243A 

2833  243A 

2S41  243A 

2B4S  243A  REM 

2B45  243A  REM 

2845  243A  198 

2BS8  243A 

2850  243A 

2B66  243E 

2B66  243E  199  REM 


2B67  243E  REM . END  OF  MODULE  RACREAO.MOO . 

2867  243E 

2867  243E  IF  M.ERR  »  0  THEM  GOTO  997 

2876  243E  LPRIMT  "LITHO  0  ";HTHOS;“  ...ERRORS" 

2888  243E  FOR  1997  =  1  TO  M.ERR 

2895  2440  LPRIMT  USING  "000  ";I997; 

2BA1  2442  LPRIMT  "==>  “;E0.MSG$(I997) 

2887  2442  NEXT  1997 

2BC8  2442  LN. COUNT  °  LN. COUNT  +  N.ERR  *  1 

2804  2444  CNTRLOPT  >  6 

2808  2444  GOSUB  9010  'REJECT  THE  FORM 

2BE0  2444  GOTO  998  'BYPASS  THE  DISK  WRITER _ 

2BE4  2444 

2BE4  2444  997  REM  {INCLUDE;  'RACURI T .MOO'  REM  INCLUDE  THE  BASE  FORH  DISK  WRITER 


2BE5  2444  REM  •**»' 

2BE5  2444  REM  •*** 

2BE5  2444  REM 

2BE5  2444  REM  ***• 

2BE5  2444  REM 

2BE5  2444  REM 

28E5  2444  REM 

2BE5  2444  REM  **** 


AMBULATORY  CARE  INFORMATION  SYSTEM  10  MAR  87  **** 

D  R  BOLLING  •••• 

MODULE  NAME  :  RACWRIT.MOO  •••• 

SCANNER  PROGRAM  0  :  GENERAL  FORM  **** 


IF  PGMIOt  a  *730''  THEN  198  'DO  SPEC  PROG  FOR 

IF  PCMIDS  a  "740"  THEN  198  '  PSYCHOLOGY,  PSYCHIATRY  AND 

IF  PCMIDS  a  Mreo"  THEN  198  '  SOCIAL  WORK  ONLY 

GOTO  199 

SPEC  PROGRAMS 
•••  READ  AS  ARRAY 
INP,STO$aMIDS<TEXT$,T.POS,7) 

GOSUB  5700  'CONVERT  ARRAY 

SPPROGSaBUF.STOS  'UP  TO  7  TWO  DIGIT  COOES 


X.STOaINSTR(M.STO,INP.STOi,“1") 

IF  X.STOaO  THEN  GOTO  195  'THATS  ALL 

N.STOaX.STO  +  1  'NEXT  STARTING  POINT 

DX2.BUFSaOX2.BUF$  *  DIAGN.TABS(X.STO)  'ADO  CODE  TO  BUFFER  BY  FIVES 
IF  N.STO  <=  LEN(INP.STOS)  THEN  GOTO  194 
IF  SECDXSa"  •  THEN  GOTO  196 

OX2.BUFSaOX2.BUFS+SECOX$  'ADO  OTHER  SEC  DX  IF  THERE 


PURPOSE 


CREATE  AND  WRITE  THE  DISK 
RECORD  FOR  INPUT  TO  FOCUS 
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2BES  2444  REM  *•** 

2BE5  2444  REM  •**•****«*«-****«*******•**»•*•**•»*»•*********•***•*•***«**»******« 

2BE5  2444  REM  *•••  RESERVED  LINE  NUMBERS  200-299 

2BES  2444  REM  ••**•*••***••*•**•*«••*•******•••*••*•**.•****•.••*****•*.«.•**•*•• 

2SES  2444 

2BE5  2444  REM  BUILD  THE  OUTPUT  RECORD 

2BES  2444 

2BES  2444  200  GOSUB  276  ‘BUILD  THE  RECORD  KEY 

2BEA  2444 

2BEA  2444  REM  •**••••**•****•••••••**•*••*•***•*••••••*•*••*•.•••••*•**.•*«**•«•* 

28EA  2444  REM  ****  RECORD  TYPE  "I"  -  MAIN  TRANSACTION  *•** 

2SEA  2444  REM  ****«*«««***«**««*««*««**««****««***«Hk******«**«******«**«***»***«« 

2BEA  2444 

2BEA  2444  COSUB  278  'BUILD  DATA  FOR  TYPE  1 

2BEF  2444  RECOUTS  »PCHI0$+“1“+RECKEYS+RECOO1$  'TRANSACTION  ID  PLUS  RECORD 

2C09  2450  GOSUB  280 

2C0E  2450  PRINT  #1, RECOUTS 

2C19  2450 

2C19  24S0  REM  *******•««•***««**««*««**•***************•**»**********♦******«*«*« 

2C19  2450  REH  RECORD  TYPE  "2''  •  RECKEY  PLUS  PROCEDURE  CODE 

2C19  2450  REM 

2C19  2450 

2Ct9  2450  REM  *•*  ADD  ADDITIONAL  PROCEDURES  IF  ANY  ••• 

2C19  2450  IF  ADOPISo''  »  AND  PR2PRC1$»“N"  THEN  ESP.BOF1S*ESP.BUF1S+ADOP1S 

2C4B  2450  IF  AD0P2S<>''  "  AND  PR2PRC2$="N''  THEN  ESP.BOFl$=ESP.BOf  1S+A00P2$ 

2C7D  2450 

2C7D  2450  IF  ADDPISo"  "  AND  PR2PRC1$="Y"  THEN  ESP.BUF2$=ESP.BUF2$+ADDP1$ 

2CAF  2450  IF  ADDP2$<>"  "  AND  PR2PRC2$=“Y"  THEN  ESP.8UF2$=ESP.BUF2S+ADDP2$ 

2CE1  2450 

2CE1  2450  REM  *•*  PROCESS  PROV  1  PROCEDURES  *•* 

2CE1  2450 

2CE1  2450  IF  LEN(ESP.BUF1$)=0  THEN  GOTO  206 

2CF2  2450 

2CF2  2450  RPOINT*! 

2CF9  2452  202  REC002t=MI0t<ESP.8Uf 1$,RPOINT,S) 

2D0C  2456  IF  REC002$="  "  THEN  GOTO  204 

2D  IE  2456 

2D1E  2456  REC0OT$=PGMID$+"2"+RECKEY$+"1"+RECOO2$  'TRANSACTION  ID  PLUS  RECORD 

203E  2456  GOSUB  280 

■'043  2456  PRINT  #1, RECOUTS 

2D4E  2456 

2D4E  2456  204  RPOINT  =  RPOINT  ♦  5 

2058  2456  IF  RPOINT  <  LEN(ESP.8UF1$)  THEN  GOTO  202 

2D6B  2456 

206B  2456  REM  PROCESS  PROV  2  PROCEDURES  **• 

2D6B  2456 

206B  2456  206  IF  LEN(ESP.BUF2$)=0  THEN  GOTO  212 

207C  2456 

2D7C  2456  HPOINT=1 

7083  2456  208  REC002t=MIDS(ESP.BUF2t, RPOINT, 5) 

2096  2456  IF  REC002$="  "  THEM  GOTO  210 

2048  2456 

2DA8  2456  REC0UT$=Pr,Minl»"2"+RECI(EY$+"2"*REC002$  'TRANSACTION  10  PLUS  RECORO 

2DCB  2456  GOSUB  280 
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RACPGEN 

GENERAL  FORM  DESTRING/DECCOE  PROGRAM 


Offset 

Data 

Source  Line 

2000 

24S6 

PRINT  #1, RECOOTS 

2D0B 

2456 

200B 

2456 

210 

RPOINT  3  RPOINT  +  5 

20E5 

2456 

IF  RPOINT  <  LENT ESP. BUF2S)  THEN  GOTO  208 

20F8 

2456 

20f8 

2456 

212 

REM  ENO  OF  TYPE  2  RECORDS 

20F9 

2456 

REM 

2DF9 

2456 

REM 

•••*  RECORD  TYPE  "3'‘  -  RECKEY  PLUS  SPECIFIC  PRE  CLINIC  COOES 

2DF9 

2456 

REM 

20F9 

2456 

IF  LEN(SPE.BUFS)30  then  218 

2E06 

2456 

2E06 

2456 

RPOINTsI 

2E00 

2456 

214 

X3S3MIDS(SPE.BUF$, RPOINT, 2) 

2E20 

245A 

IF  X3S="10"  THEN  REC003t3"M"  :GOTO  215 

2E3B 

245E 

IF  X3$=“11"  THEN  REC003$="L"  ;GOTO  215 

2ES6 

245E 

IF  X3$="12«  THEN  REC003S=“X”  :GOTO  215 

2E71 

245E 

2E71 

245E 

REC003S3RIGHTS(X3$,1) 

2Eeo 

245E 

IF  REC003S3«  ••  THEN  216 

2E8E 

245E 

2E8E 

245E 

215 

RECOUT$=PCMIO$  ♦  "3“  ♦  RECKEYS  ♦  REC003S 

2EA8 

245E 

GOSUB  280 

2EA0 

245E 

PRINT  #1,REC0UT$ 

2EB8 

24  5E 

2EB8 

245E 

216 

RPOINT=RPOINT+2 

2EC1 

245E 

If  RPOINT  <  LEM(SPE.BUFS)  THEN  214 

2E00 

245E 

2ED0 

245E 

218 

REM  ENO  OF  TYPE  3  RECORDS 

2E01 

245E 

2ED1 

245E 

REM 

2E01 

245E 

REM 

*•••  RECORD  TYPE  "4"  -  RECKEY  PLUS  OTHER  COOES 

2E01 

245E 

REM 

2ED1 

245E 

2EOI 

245E 

IF  LEN(OTH.SUF$)=0  THEN  GOTO  224 

2EE2 

245E 

2EE2 

245E 

RPOINT=1 

2EE9 

245E 

220 

REC004$3MIDS(0TH.BUFS, RPOINT, 5) 

2EFC 

2462 

IF  REC004t="  "  THEN  GOTO  222 

2F0E 

2462 

2F0E 

2462 

RECOUT$3pGMI0$+"4"+RECKEY$+REC0O4$  'TRANSACTION  10  PLUS  RECORD 

2F28 

2462 

GOSUB  280 

2F20 

2462 

PRINT  «1,REC0UT$ 

2F38 

2462 

2F38 

2462 

222 

RPOINT  3  RPOINT  ♦  5 

2F42 

2462 

IF  RPOINT  <  LEHCOTH.BUFS)  THEN  GOTO  220 

2F55 

2462 

2F55 

2462 

2F55 

2462 

224 

REM  END  OF  TYPE  4  RECORDS 

2FS6 

2462 

2462 

2F56 

2462 

REM 

**•*  RECORD  TYPE  "5"  -  RECKEY  PLUS  GROUP  I  DATA  ••** 

2F56 

2F56 

2462 

2462 

REN 
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2F56 

2462 

REM 

•***  RECORD  TYPE  "6"  -  RECKEY  PLUS  SPECIAL  PROGRAMS 

**** 

2F56 

2462 

REM 

««********•*«*«««•***«****«***«*«**«**•*******»****•*•«•«»»***«***** 

2FS6 

2462 

IF  LEN(SPPROGS)>0  THEN  262 

2F63 

2462 

2f63 

2462 

RPOINT=1 

2F6A 

2462 

258 

REC006S=R I GHTS(M I DS<  SPPfiOGS . RPOI NT , 2) , 1 > 

2F83 

2466 

IF  REC0D6S3H  ••  then  260 

2F91 

2466 

2F91 

2466 

RECOUTSsPGMIOS  *  "G"  +  RECKEYS  *  RECQ06S 

2FAB 

2466 

GOSUB  280 

2FB0 

2466 

PRINT  BI.RECOUTS 

2FBB 

2466 

2FB8 

2466 

260 

RPOIHT*RPOIHT*2 

2FC4 

2466 

IF  RPOINT  <  LEM(SPPROGS)  THEN  258 

2FOQ 

2466 

2FDQ 

2466 

262 

REM  END  OF  TYPE  6  RECORDS 

2fD1 

2466 

2F01 

2466 

REM 

*««** 

2F01 

2466 

REM 

RECORD  TYPE  “7"  -  RECKEY  PLUS  SECOND  DK  CODE 

***• 

2F01 

2466 

REM 

***** 

2F01 

2466 

2F01 

2466 

IF  LEN(DX2.BUFS)«0  THEN  GOTO  268 

2FE2 

2466 

2FE2 

2466 

RPOINT=1 

2FE9 

2466 

264 

REC007$*MI0S(0X2.BUF$, RPOINT, 5) 

2FFC 

246A 

IF  RECOOTSs"  «  THEM  GOTO  266 

300E 

246A 

300E 

246A 

RECOUTS  =PGHIO$+"7"+RECKEY$+REC007S  'TRANSACTION  ID  7 

3028 

246A 

GOSUB  280 

3020 

246A 

PRINT  #1, RECOUTS 

3038 

246a 

3038 

246A 

266 

RPOINT  *  RPOINT  ♦  5 

3042 

246A 

IF  RPOINT  <  LEN<0X2.BUf$)  THEN  GOTO  264 

3055 

246A 

3055 

246A 

268 

REM  END  OF  TYPE  7  RECORDS 

3056 

246A 

3056 

246a 

REM 

***** 

3056 

246A 

REM 

****  RECORD  TYPE  "8"  -  RECKEY  PLUS  PSYCHOMETRIC  ASSESSMENTS 

**** 

3056 

246a 

REM 

****«•**«***««**«*«•«*««*****««***■*■**«*«««*«****«*******«*««*«***•** 

3056 

246A 

IF  LEM ( PSYCHOS )=0  THEN  274 

3063 

246A 

3063 

246A 

RPOINT=1 

306A 

246A 

270 

REC008$=RIGHT$(MIDS<PSYCH0S,RP0IMT,2),1) 

3083 

246E 

IF  REC(»8$="  "  THEM  272 

3091 

246E 

3091 

246E 

RECOUTS=PGMID$  ♦  "8"  +  RECKEYS  ♦  RECOOSt 

30AB 

246E 

GOSUB  280 

30B0 

246E 

PRINT  #1, RECOUTS 

3088 

246E 

30BB 

246E 

272 

RPOINT=RPOINT+2 

30C4 

246E 

IF  RPOINT  <  LEN(PSYCHOS)  THEN  270 

3000 

245E 

3000 

246E 

274 

REM  END  OF  TYPE  R  RECORDS 

246E 

RACPGEM 

GENERAL  FORM  OESTRING/DECCSE  PROGRAM 
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3001  248E  REM 


3001  246E  REM  PHYSICAL  THERAPY  MAY  NEED  SEPARATE  RECORDS  IF  THE  OTHER 

3001  246E  REN  UCA  CODE  IS  BUBBLED.  INDICATOR  PMTH-1  IF  COOED. 

300 1  246£  REM  *•*****••*********•*************•*»••»***«*******#•«*»*• 

30D1  246E  IF  PHTH<>1  THEN  275  '  GO  IF  NOT  *1 

300C  246E  PHTH»0  •  RESET  INDICATOR 

30E3  246E  CL1 .CODS»'DHOA«  ■  PROVIDE  NEU  UCA  CODE 

30EC  246E  . . .  '  DONT  ADO  THESE  AGAIN  THE  SECOND  TINE  AROUND 

30FE  246E  GOTO  200  >  GO  AROUND  AGAIN 

3102  246E 

3102  246E  275  GOTO  299 

3106  246E 

3106  246E  REM 

3106  246E  REM  ••••  SUBROUTINE  270  -  BUILD  THE  RECORD  KEY 

3106  246E  REM 

3106  246E  276  RECKEYSx"" 

31  OF  246E 

310F  246E  REM  CLINIC  ID  (PREFIX  ♦  COO) 

310F  246E  RECKEYS«  CL  1. COOS 

3118  246E 

3118  246E  REM  *•*  VISIT  DATE  *•* 

3118  246E  RECKEYS«RECKEY$4  VIOATES 

3124  246E 

3124  246E  REN  **•  PRIMARY  PROVIDER 

3124  246E  RECKEYS  <  RECKEYS  *  PPROV.PFXS  *  PPROV.NUHS 

3137  246E 

3137  246E  REM  •••  PATIENT  SSN 

3137  246E  RECKEYS  »  RECKEYS  ♦  SSNS 

3143  246E 

3143  246E  REM  ***  FAMILY  MEMBER  PREF 

3143  246E  RECKEYS  «  RECKEYS  ♦  FMEMPS 

314F  246E 

314F  246E  REM  •••  LITHO  CODE 

314F  246E  RECKEYS  »  RECKEYS  ♦  LITHOS 

315B  246E 

31 5B  246E  REM  •••  FORM  NUMBER  **• 

31 SB  246E  RECKEYS  >  RECKEYS  *  FRMNS 

3167  246E 

3167  246E  RETURN 

316A  246E 

316A  246E  REM 

316A  246E  REM  SUBROUTINE  272  -  BUILD  THE  DATA  FOR  TYPE  1  •••• 

316A  246E  REM 

316A  246E  278  REC001S="“ 

3173  246E 

3173  2461  REM  VISIT  COUNT 

3173  246E  REC001S  *  REC001S  +  VCNTS 

317F  246E 

317F  246E  REM  •••  PRIMARY  PROV  TIME  •** 

31 7F  246E  REC001S  =  REC001S  ♦  PPROV.TIMS 

318B  246E 

318B  246E  REM  •**  SECONDARY  PROVIDER 

3188  246E  RECOOIS  »  REC001S  ♦  SPROV.PFXS  ♦  SPROV.NUMS 

319E  246E 


8ACPGEN 

GENERAL  FORH  DESTRIMG/DECOOE  PROGRAM 


OFfstt 

Data 

Source  Line 

319E 

246E 

REM 

***  SECONDARY  PROVIDER  TIME 

319E 

246E 

REC001S  <  REC0D1S  *  SPROV.TIMS 

3TAA 

246E 

31AA 

246E 

REM 

***  REASON  FOR  SECONDARY  PROVIDER  ••• 

31AA 

246E 

REC001S  >  REC001S  *  SPROV.REAS 

31B6 

246E 

31B6 

246E 

REM 

APPORINTHENT  STATUS  *•* 

31 B6 

246E 

REC001S  •  REC001S  *  NOTSCS 

31C2 

246E 

31C2 

246E 

REM 

•**  REFERRAL  CODE  ••• 

31C2 

246E 

RECOOIS  :  REC001S  *  REF.PFXS  +  REF.CQOS 

31D5 

246E 

3105 

246E 

REM 

•••  PLACE  OF  VISIT  ••• 

3105 

246E 

RECOOIS  <  RECOOIS  *  NOTCLS 

31E1 

246E 

31E1 

246E 

REM 

•**  JOB  RELATED  VISIT 

31E1 

246E 

RECOOIS  s  RECOOIS  >  RELAT.VISS 

31ED 

246E 

31ED 

246E 

REM 

**•  MIL  ONLY  DUTY 

31E0 

246E 

RECOOIS  c  RECOOIS  *  MILOUTS 

31F9 

246E 

31F9 

246E 

REN 

MIL  ONLY  QTRS  ••• 

31 F9 

246E 

RECOOIS  3  RECOOIS  MILOTRS 

3205 

246E 

3205 

246G 

REM 

**•  MIL  ONLY  PROFILE  •** 

.’205 

246E 

RECOOIS  <  RECOOIS  MILPROS 

3211 

246E 

3211 

246E 

REM 

NOT  AVAILABLE  *** 

3211 

246E 

RECOOIS  =  RECOOIS  +  NAVAILS 

7210 

246E 

3210 

246E 

REM 

***  ADMITTED  •** 

3210 

246E 

RECOOIS  =  RECOOIS  ♦  ADMITS 

3229 

246E 

3229 

246E 

REM 

INFIELD  (NOT  ON  GENERAL  FORH)  ••• 

3229 

246E 

RECOOIS  X  REC001S  ♦  " 

7235 

246E 

3235 

246E 

REM 

*•»  INJURY  (NOT  ON  GENERAL  FORM)  *** 

3235 

246E 

RECOOIS  =  REC001S  ♦  "  >' 

3241 

246E 

3241 

246E 

REM 

PURPOSE  OF  VISIT  (NOT  ON  GENERAL  FORM)  •** 

3241 

246E 

RECOOIS  X  RECOOIS  ♦  '•  " 

3240 

246E 

32.,D 

246E 

REM 

•**  PRIM  FOLLOV-UP/RULE  OUT 

3240 

246E 

RECOOIS  X  RECOOIS  +  FU.ROS 

3259 

246E 

3 '59 

246E 

REM 

•**  PRIMARY  OX  CODE  *** 

3259 

246E 

RECOOIS  X  REC001S  *  PRIMOXS 

3265 

246E 

32  5 

246E 

RETURN 

3268 

246E 

’268 

246E 

ffEM 

3268 

246E 

REM 

****  SUBROU^I^£  280  -  PAD  THE  RECORD  TO  MAXIENGTH 

3 

REM 

32^3 

246E 

280 

PAOxMAXLEHOTH  -  LEN(RECOUTS)  'FIND  OUT  HOU  SHORT 
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3276 

2470 

3289 

2470 

328C 

2470 

328C 

2470 

3280 

2470 

3280 

2470 

3280 

2470 

3280 

2470 

328E 

2470 

328E 

2470 

3295 

2470 

32AS 

2472 

32A9 

2472 

32A9 

2472 

32A9 

2472 

32A9 

2472 

32AA 

2472 

32AA 

2472 

32AA 

2472 

32AA 

2472 

32AA 

2472 

32AA 

2472 

32AA 

2472 

32AA 

2472 

32AA 

2472 

32AA 

2472 

32AA 

2472 

32AA 

2472 

32AA 

2472 

32BC 

2472 

32CA 

2472 

32EB 

247E 

32F9 

247E 

3307 

247E 

330E 

247E 

3324 

247E 

333A 

247E 

333E 

247E 

3341 

247E 

5341 

24  7E 

3345 

24  7E 

334C 

24  7E 

334C 

24  7E 

334C 

247E 

3340 

247E 

3340 

24  7E 

3340 

247E 

3340 

247E 

334D 

24  7E 

3340 

247E 

3340 

247E 

3340 

247E 

3340 

247E 

3340 

24  7E 

REDOUTS  >  RECOUTS  *  STRINGS<PAO,PAOS)  'PAO  THE  RECORD  WITH  FILL  CHAR 
RETURN 

299  REM 


REM . END  OF  MODULE  RACWRIT.MOD . . 

998  REM  CONTINUE 

999  REAOTYPE  »  2 

IF  LNLCOUNT  >  48  THEN  GOSUB  7100  'PRINTER  HEADING 
GOTO  10 


REM  END  OF  SCAN/DECOOE/URITE  LOOP  »====»=»«==*==»*====»==»==»«=»*»»■ 


1000  REM  SINCLUOE:  'RACSIOOO.SUB*  INCLUDE  THE  VERIFY  LOGON  SUB 
REM 

REM  *  NAME:  RACS1000  LOGON  VERIFICATION  SUBROUTINE  * 

REM  *  Date:  28  Feb  84  PATIENT  REGISTRATION  PROGRAM  * 

REM  *•*•**••••••••••*••»•••••**•******•••*••••••••*•**«•*****•*••*•*•*•** 

REM  PATIENT  OMR  INPUT  PROGRAM  * 

REM  * 

REM  This  program  verifies  user  is  logged  on  properly.  If  there  is  no  • 
REM  valid  user  logged  on  at  the  time  of  execution,  this  subroutine  will* 
REM  chain  to  the  logon  program  RACPOS,  otherwise  a  return  is  issued.  * 
REM 

REM  RESERVED  LINE  NUMBERS  ARE  1001  THRU  1010 

REM  •••*•••••••••**••***••••*•••*••**••***•*••**•»**».**•••»*•*•**•••*.*• 

1001  OPEN  "I",1,"RACLOG.OAT'' 

IF  E0F(1)  THEN  1002  'MAKE  THEM  LOG  ON  FIRST 

INPUT  #1,USER$(1),0T$,TM$,PID$ 

IF  USERSd)  3  ""  THEN  1002  'MAKE  THEM  LOG  ON  FIRST 

IF  USERSd)  »  "*••••*"  THEN  1002  'MAKE  THEM  LOG  ON  FIRST 

CLOSE  1 

SCREEN  0,1, 0,0 
COLOR  FORE, BACK, BORO 
CLS 

RETURN 


1002  CLOSE 

CHAIM  "RACPOS" 

•==r====s=*sEN0  OF  LOGON  VERIFY  SUBROUTINE  1000==”=="======="===*»===»*- 


AMBULATORY  CARE  DATA  BASE 


2000  REM  SINCLUOE:  ■RACS2000.SU8'  INCLUDE  THE  RIPLY/DELAY  SUB 
REM 
REM 
REM 
REM 
REM 

REM  ***• 

REM  •*»* 

REM  *•»* 

REM 
REM 


SUBROUTINE  NAME 
SCANNER  PROGRAM  $ 
FUNCTION 


13  APR  85 
SKIP  COLE 

RACS2000.SUB 

ALL 

THIS  SUBROUTINE  MODULE 
SERVERS  AS  A  UAIT  AND  REPLY 
ENTRY  MODULE 
SINGIE  KEYBOARD  ENTRY 


*•** 


INPUT 


RArPCEN 

GENERAL  FORM  DESTRING/DECOOE  PROGRAM 


Offstt 

33A0 

33AD 

3340 

3340 

3340 

3340 

334E 

3362 

336C 

3387 

3383 

3386 

3386 

3387 
3387 
3387 
3387 
3387 
3387 
3387 
3387 
3387 
3387 
3387 
3387 
3387 
3387 
3387 
3387 
3387 
3387 
3337 
3387 
3337 
3387 
3387 
338E 
3301 
73E7 
33FA 
33FA 
3410 
3426 
343C 
3452 
3452 
3452 
3459 
3 '.68 
3470 
3484 
3484 
34A3 
34A3 


Data 

Sourc 

247E 

REN 

247E 

REM 

247E 

REN 

247E 

REN 

247E 

REM 

247E 

2001 

247E 

2002 

2482 

2484 

2484 

2484 

2484 

2484 

5000 

2484 

REN 

2484 

REM 

2484 

REM 

2484 

REM 

2484 

R  H 

2484 

REM 

2484 

REM 

2484 

REM 

2484 

REM 

2484 

REM 

2484 

REM 

2484 

REM 

2484 

REM 

2484 

REM 

2484 

REM 

2484 

REM 

2484 

REM 

2484 

REM 

2484 

REM 

2484 

REM 

2484 

REN 

2484 

REM 

2484 

2484 

2486 

2488 

248A 

248A 

248A 

248A 

248A 

248A 

248a 

REM 

248A 

248a 

248A 

248A 

248A 

248A 

5005 

240A 

24BA 

5009 
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*••• 

**** 

•*** 

**** 


OUTPUT 

RESERVED  LINE 
NUMBERS 


KEYBOARD  ENTRY  -  UPPER  CASE 


:  2001-2010 


**** 

«*** 


REM  REPLY  FUNCTION 

REPLYS=INKEY$  :  IF  REPLYS="“  THEN  2002 

REPLY=ASC{REPLY$) 

IF  REPLY  >  90  THEN  REPLY$=CHR$(REPLY  XOR  32)  ‘CONVERT  TO  CAPS 
IF  REPLYS  <  "A"  OR  REPLYS  >  “2“  THEN  R£PLYS=“?“ 

RETURN 

REM  SINCLUOE:  ■ RACSSOOO . SUB •  INCLUDE  THE  DATE  EDITOR  SUB 


**«* 

**** 

**** 

**»* 


AMBULATORY  CARE  DATA  BASE 


SUBROUTINE  NAME 
SCANNER  PROGRAM  « 
FUNCTION 


**«« 

«*** 

«*«« 

•••• 

**** 

«*«* 

***• 

•**« 

**«* 

**** 

**** 


INPUT 


OUTPUT 


13  APR  85 
SKIP  COLE 

RXXSSQOO.SUB 

ALL 

THIS  SUBROUTINE  MODULE 
PERFORMS  A  DATE  EDIT 

DATE  TO  BE  CHECKED  MUST  BE 
IN  THE  VARIABLE  NAMED 
•CK.5000S' 

IN  THE  FORMAT  "YYHMOO" 

'RT.5000'  IS  THE  RETURN  CODE 
VARIABLE.  IF  THIS  VARIABLE 
CONTAINS  AMY  NUMBER  OTHER 
THAN  0,  AN  ERROR  WAS  FOUND 
IN  THE  DATE. 


**** 

**** 

**** 

***» 

**** 


**** 


RESERVED  LINE 
NUMBERS 


*«** 

**** 

•*»* 

•*** 

*««* 

**** 

**** 

**«* 


;  5001-5009 

******««««*««i»#*ir*###********i»*******ir*************»*****^********* 

RT.5000  =  0 

CKYEAfi  »  VAL(LEFT$<CK.5000$,2))  'YEAR  NUMERIC  VALUE 
CKMONTH  =>  VAL(MIOt(CK.5000$,3,2))  'MONTH  NUMERIC  VALUE 
CKDAY  =  VAL<RIGHTS{CK.5000$,2))  ‘DAY  NUMERIC  VALUE 

IF  CKMONTH  <  1  THEN  RT. 5000=1  :  GOTO  5009 

IF  CKMONTH  >  12  THEM  RT. 5000=1  :  GOTO  5009 

IF  CKDAY  <  1  THEN  RT. 5000=2  :  GOTO  5009 

IF  CKDAY  >  31  THEN  RT. 5000=2  :  GOTO  5009 


LEAP  YEAR  CHECK 
M0LENGTH(2)  =  28 

IF  CKMONTHo  2  THEN  GOTO  5005 
IF  (CKYEAR  MOO  4)  <>  0  THEM  GOTO  5005 
MOLENGTH(2)  =  29 


‘MUST  BE  FEBRUARY 
‘MUST  BE  A  LEAP  YEAR 
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34  A6 

248A 

34A6 

248A 

34A6 

2488 

34A6 

248A 

5500  REN  INCLUDE:  'RACSSSOO.SUB' 

INCLUDE  THE  OUTP  UCA  VALIDATE  SUB 

34A7 

248A 

5600  REM  INCLUDE:  ■RACSS600.SUB> 

INCLUDE  THE  INP  UCA  VALIDATE  SUB 

34A8 

248A 

5700  REN  SINCLUOE:  ■ RACS5700 . SUB ■ 

INCLUDE  MAP  ONES  TO  POSITION  NO. 

34A9 

248A 

REM 

34A9 

248A 

REM 

AMBULATORY  CARE  OATA  BASE  29  JUL  85 

»*** 

34A9 

248A 

REM 

«««« 

D  R  BOLLING 

**** 

34A9 

248A 

REM 

SUBROUTINE  NAME 

:  RXXS5700.SUB 

**** 

34A9 

248A 

REM 

SCANNER  PROGRAM  # 

:  ALL 

34A9 

248A 

REM 

FUNCTION 

:  THIS  SUBROUTINE  MODULE 

34A9 

248A 

REM 

CONVERTS  A  BINARY  ARRAY  INTO 

34A9 

248A 

kkM 

TWO  CHAR  COOES. 

*«** 

34A9 

248A 

REM 

*««* 

*•** 

34A9 

248A 

REM 

•••*  input 

:  INP.STOS  AS  STRING 

34A9 

248A 

REM 

*«*« 

«*•* 

34A9 

248A 

REM 

*•** 

**•# 

34A9 

248A 

REM 

****  OUTPUT 

;  BUF.STOS  AS  STRING. 

•  *** 

34A9 

248A 

REM 

*«** 

34A9 

248A 

REM 

««*« 

34A9 

248A 

REM 

RESERVED  LINE 

34A9 

248A 

REM 

•••*  NUMBERS 

:  5710-5730 

**•* 

34A9 

24SA 

REM 

*«***««*********«**«***«***»*****«*t»**-***«*******«****tt****tk  ****««« 

34A9 

248A 

34A9 

248A 

BUF.STO$="" 

3482 

248A 

N.ST0=1 

3489 

24SA 

5710 

X.STO=INSTR(N.STO,INP.STO$ 

,"1") 

34C8 

248A 

IF  X.STO=0  THEN  GOTO  5720 

■THATS  ALL 

340A 

248A 

N.STO  *  X.STO  +  1 

'NEXT  STARTING  POINT 

34E2 

248A 

X.STO  =  X.STO  ♦  100 

•PAD  WITH  LEADING  ZERO 

34EC 

248A 

BUF.STOS  =  BUF.STOS  ♦  RIGHT$(STRt<X.ST0),2) 

3502 

248A 

IF  N.STO  <=  LEN(INP.STOS) 

THEN  GOTO  5710 

3515 

248A 

3515 

24SA 

5720 

RETURN 

3518 

248A 

3518 

248A 

5800 

REH  SINCLUOE:  'RACSSSOO.SUB' 

INCLUDE  FOUR  COL  OX  CONVERTER 

3519 

248A 

REM 

»*•** 

3519 

248A 

REM 

•»*  AMBULATORY  CARE  DATA  BASE  30  JUL  85 

3519 

248A 

REM 

*** 

D  R  BOLLING 

•** 

3519 

248A 

REM 

•••  SUBROUTINE  NAME  : 

RXXS5800.SUB 

*** 

3519 

248A 

REM 

•**  SCANNER  PROGRAM  : 

AS  APPROPRIATE 

%** 

3519 

248A 

REM 

•••  FUNCTION  : 

THIS  SUBROUTINE  MODULE  READS 

*** 

3519 

2488 

REM 

*•* 

FOUR  COLUMNS  IN  OX  AREA  AND 

3519 

248A 

REM 

*»* 

CONVERTS  TO  A  POSITION  IN  A 

*♦* 

3519 

248A 

REM 

*** 

TABLE.  AN  ERROR  CODE  IS 

3519 

248A 

REM 

RETURNED  IF  MULTIPLE  COOES  ARE 

3519 

248A 

REM 

•  ** 

PRESENT. 

*** 

3519 

248A 

REM 

•  ** 

*** 

3519 

248A 

REM 

INPUT 

X.POS  -  STARTING  POSITION  IN 

*** 

3519 

248A 

REH 

•  ** 

STRING 

•  *« 

3519 

248A 

REH 

*«• 

•  ** 

RACPGEN 

GENERAL  FORM  DESTRING/DECOOE  PROGRAM 


PAGE  27 
07-06-87 
1A:51:36 


offset 

Data 
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3519 

248a 

REM  OUTPUT  :  X.FIM  -  TABLE  POSITION  Of  OX 

*** 

3519 

24aA 

REM  RT.5800  »  1  ON  ERROR 

*** 

3519 

248A 

REM  ••• 

*** 

3519 

24aA 

REM  ***  RESERVED  LINE  NUMBERS  :  5801  -  5899 

3519 

24aA 

REM  *•••••*•**»•••••*•»*•*•»*••••••••••••*«••••«*•••*•♦•• 

3519 

24aA 

RT. 5800=0  'INITIALIZE  ERROR  INDICATOR 

3520 

X.FIN=0  'INITIALIZE  TABLE  OFFSET  RESULT 

3527 

24aA 

3527 

248A 

REM  ••  COLUMN  1  •• 

3527 

248A 

X=0  'STARTING  POINTER 

352E 

X.SIZ=C1SIZ 

3535 

ZiSC 

X.ST0=VAL(MIDS(TEXT$,X.P0S,2)) 

35AC 

248C 

IF  X.STO=0  THEN  GOTO  5802 

355B 

248C 

X.F!N=X.STO 

3562 

2480 

3562 

248C 

5802  REM  ••  COLUMN  2  •* 

3563 

248C 

IF  C2SIZ=0  THEN  GOTO  5804 

3572 

248C 

X=X*X.SI2 

3570 

248C 

X.POS=X.POS*2 

3536 

248C 

X.SIZ=C2SIZ 

3530 

248C 

X.ST0=VAL<MIDS<TEXTS,X.P0S,2>> 

35a4 

248C 

IF  X.STO=0  THEN  GOTO  5804 

3583 

248C 

IF  X.FINoO  THEN  GOTO  5890  'ERROR  -  MULTIPLE 

CODE 

35C2 

248C 

x.FtN=x,sro  ♦  X 

35CD 

243C 

35C0 

2480 

5804  REM  •*  COLUMN  3  ** 

35CE 

2480 

IF  C3SIZ=0  THEN  GOTO  5806 

3500 

2480 

x=x*x.stz 

35E8 

2480 

X.POS=X.POS*2 

35F1 

2480 

X.SIZ=C3SIZ 

35F8 

2480 

X.ST0=VAL(HID$(TEXT$,X.P0S,2)) 

360  F 

2480 

IF  X.STO=0  THEM  GOTO  5806 

361 E 

2480 

IF  X.FINoO  THEN  GOTO  5890  'ERROR  -  MULTIPLE 

CODE 

3620 

2480 

X.FIN=X.STO  ♦  X 

3633 

2480 

3638 

2480 

5806  REM  •*  COLUMN  4  ** 

3639 

2480 

IF  C4SIZ=0  THEN  GOTO  5808 

3648 

2480 

X=X+X.SI2 

3653 

2480 

X.POS=X.POS*2 

365C 

2480 

X.SIZ=C4SIZ 

3663 

2480 

X.STO=VAL(HID$(TEXT$,X.POS,2)) 

367A 

2480 

IF  X.STO=0  THEN  GOTO  5808 

3689 

2480 

IF  X.FINOO  THEN  GOTO  5890  'ERROR  -  MULTIPLE 

CODE 

3698 

2480 

X.FIN=X.STO  ♦  X 

36A3 

2480 

36A3 

2480 

5808  REM 

MU 

2480 

GOTO  5899 

36A8 

2480 

36A8 

2480 

5890  RT. 5800=1  'ERROR  -  MULTIPLE  COOES 

36AF 

2480 

36AF 

2480 

5899  RETURN 

3682 

2480 

3602 

2480 

! 
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36B2 

248C 

36B2 

2480 

6000  REM  SINCLUOE:  '84036000.508'  IKCLUOE  THE  INSTRtNG  DECODE  SUB 

36B3 

2480 

REM 

36B3 

2480 

REM 

***• 

AMBULATORY  CARE  DATA  BASE  13  APR  85 

**»* 

36B3 

2480 

REM 

***• 

SKIP  COLE 

*•«* 

36B3 

2480 

REM 

**«* 

SUBROUTINE  NAME  :  RXXS6000.SUB 

*•** 

36B3 

2480 

REM 

***• 

SCANNER  PROGRAM  «  :  ALL 

3683 

2480 

REM 

**«* 

FUNCTION  :  THIS  SUBROUTINE  MODULE 

36S3 

2480 

REM 

PERFORMS  INSTRING  SEARCH 

3683 

2480 

REM 

•*** 

«*«* 

3683 

2480 

REM 

INPUT  :  STRING  TO  BE  SEARCHED  MUST 

36B3 

2480 

REM 

•*** 

8E  IN  THE  VARIABLE  NAMED  : 

3683 

2480 

REM 

•XS* 

•  «** 

36B3 

2480 

REM 

36B3 

2480 

REM 

«*** 

OUTPUT  :  'TOT'  =  TOTAL  NUMBER  OF 

36B3 

2480 

REM 

HITS  IN  THE  DESTRING 

36B3 

2480 

REM 

'HOLOSO'  IS  THE  ARRAY 

•  *** 

36B3 

2480 

REM 

**** 

CONTAINING  THE  NUMERIC 

3683 

2480 

REM 

VALUE  OF  THE  HIT  POSITIONS 

3683 

2480 

REM 

*•** 

3683 

2480 

REM 

***** 

3633 

2480 

REM 

RESERVED  LINE 

*••* 

3683 

2480 

REM 

NUMBERS  :  6001-6009 

**** 

3683 

2480 

REM 

3683 

2480 

6001 

PTR  s  INSTR<X$,"1") 

36C1 

248E 

TOT  =  0 

36C8 

2490 

WHILE 

PTR  >  0 

3603 

2490 

TOT=TOT*1 

3608 

2490 

HOLDS(TOT)  =  R1GHT$(STR$(PTR),2) 

36F0 

2490 

PTR=PTR*1 

3705 

2490 

PTR  =  INSTR(PTR,X$,"1") 

3717 

2490 

WENO 

3718 

2490 

RETURN 

371E 

2490 

771C 

371E 

2490 

371E 

2490 

371E 

2490 

7000 

REM  SINCLUOE:  'RACS7000.SU8'  INCLUDE  THE  SCREEN  HEADER  SUB 

371 F 

2490 

REM 

371F 

2490 

REM 

**•* 

AMBULATORY  CARE  DATA  BASE  13  APR  85 

***• 

371F 

2490 

REM 

SKIP  COLE 

***• 

371 F 

2490 

REM 

SUBROUTINE  NAME  :  RACS7000.SU8 

**** 

371 F 

2490 

REM 

**•« 

SCANNER  PROGRAM  #  :  ALL 

*•*• 

371F 

2490 

REM 

**•* 

FUNCTION  :  THIS  SUBROUTINE  MODULE 

**** 

371F 

2490 

REM 

**** 

PRINTS  THE  STANDARD  SCREEN 

*»** 

371F 

2490 

REM 

HEADING. 

•  **• 

371 F 

2490 

REM 

*•*« 

INPUT  COMMON  VARIABLE  USEHS(2) 

*•** 

371 F 

2490 

REM 

*•** 

SYSTEM  DATE 

***• 

371F 

2490 

REM 

*•** 

*♦** 

371F 

2490 

REM 

•  *** 

OUTPUT  :  SCREEN  HEADING 

*•** 

371F 

2490 

REM 

*••• 

ft*** 

371F 

2490 

"EM 

**** 

RESERVED  LINE 

**** 

371 F 

371F 

2490 

2490 

REM 

REM 

NUMBERS  :  7001-7010 

*••* 
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371 F  2490 


371 F 

2490 

7001 

LOCATE 

1.1 

3729 

2490 

PRINT  "U.S.  ARMY  AMBULATORY  CARE  INFORMATION  SYSTEM** 

3731 

2490 

LOCATE 

1.65 

373E 

2490 

PRINT  OATES; 

3746 

2490 

LOCATE 

2.1 

3753 

2490 

PRINT  "USER  :  ";USER${1) 

3760 

2490 

RETURN 

3763 

2490 

3763 

2490 

7100  REH  SINCLUOE:  <RACS7100.SUB'  INCLUDE  THE  PRINTER  HEADER  SUB 

3764 

2490 

REM 

3764 

2490 

REH 

AMBULATORY  CARE  DATA 

BASE  13  APR  85 

3764 

2490 

REH 

***« 

SKIP  COLE 

3764 

2490 

REM 

SUBROUTINE  NAME 

RXXS7100.SUB 

**** 

3764 

2490 

REH 

*««* 

SCANNER  PROGRAM  « 

ALL 

**** 

3764 

2490 

REH 

FUNCTION 

THIS  SUBROUTINE  MODULE 

3764 

2490 

REH 

*«•* 

PRINTS  THE  STANDARD  HEADING 

**** 

3764 

2490 

REH 

•  *** 

ON  THE  PRINTER. 

**** 

3764 

2490 

REH 

**«* 

INPUT 

DATE , PACE , PGM IDS, PGHT I TLS 

**** 

3764 

2490 

REM 

*«*« 

3764 

2A9U 

REH 

««•« 

OUTPUT 

PRINTER  HEADING,  LN. COUNT 

**** 

3764 

2490 

REH 

«*«* 

**** 

3764 

2490 

REH 

«*«* 

RESERVED  LINE 

3764 

2490 

REM 

**•« 

NUMBERS 

7101-7110 

3764 

2490 

REM 

*«*«««**«*««**«*«*«**«*******•«**«**•***•************«*••**••**•*«* 

3764 

2490 

3764 

2490 

7101 

IF  PAGE  >  0  THEM  LPRINT  CHR$(12); 

377A 

2490 

LPRINT 

"ARMY  AMBULATORY  CARE  INFORMATION  SYSTEM _ ".-PGMTITLS, 

3787 

2494 

LPRINT 

TAB<70), -OATES 

379A 

2494 

PAGE=PAGE+1 

37A2 

2494 

LPRINT 

"PROGRAM  " ;  PGM  I  OS ;  T  AB(  70 ) ;  "PAGE** ; 

37BF 

2494 

LPRINT 

USING  "0W<M!";PAGE 

37CB 

2494 

LPRINT 

37D3 

2494 

LH.COUNT=3 

37DA 

2494 

RETURN 

37D0 

2494 

37D0 

2494 

8000 

REM  SINCLUOE:  'RACS8000.SUB'  INCLUDE  THE  DECODE  SUB  GROUP 

37DE 

2494 

REH 

37DE 

2494 

REM 

**** 

AMBULATORY  CARE  DATA 

BASE  13  APR  85 

*** 

37DE 

2494 

REH 

SKIP  COLE 

*** 

37DE 

2494 

REM 

**** 

SUBROUTINE  NAME 

RXXS8000.SU8 

**« 

37DE 

2494 

REM 

•*** 

SCANNER  PROGRAM  # 

ALL 

37DE 

2494 

REH 

FUNCTION 

THIS  SUBROUTINE  MODULE 

*** 

37DE 

2494 

REM 

**** 

IS  A  GROUPING  THAT  PERFORMS 

*** 

37DE 

2494 

REM 

**«« 

VARIOUS  DECODING  FUNCTIONS 

**• 

' 

37DE 

2494 

REM 

**** 

ON  THE  SCANNER  DATA 

*** 

37DE 

2494 

REM 

**•* 

*** 

37DE 

2494 

REM 

**** 

8001  -  OECQOE  THE 

HEADER  POSITIONS  (POINTER  0-20) 

*** 

37DE 

2494 

REH 

8050  -  CHECK  FOR  END  OF  JOB 

37CIE 

2494 

REM 

•  *** 

8100  -  PRINT  THE  HEADER  DATA  ON  THE  SCREEN 

«•* 

370E 

2494 

PEM 

**** 

8200  -  DECODE  THE 

RESPONSE  POSITIONS  (POINTER  21 -. 

)  *** 

jTOE 

2494 

REH 

*«** 

(RETURNED  IN  TEXTS  STRING  VARIABLE) 

*** 

2494 

REM 

**** 

3rnr 

REM 

**** 

INPUT 

SHEET  RECORD,  RECORD  UNGTH 

*** 

t 

4 
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Offset 

Data 

37DE 

2494 

37DE 

2494 

37DE 

2494 

37DE 

2494 

37DE 

2494 

37DE 

2494 

37DE 

2494 

37DE 

2494 

37DE 

2494 

37E5 

2496 

37EC 

2498 

37F3 

2498 

3811 

2498 

3819 

2498 

3828 

249A 

3837 

249E 

3849 

24A2 

385B 

24A6 

3860 

24AA 

387F 

24AE 

3891 

2482 

38A3 

2486 

3885 

248A 

38C7 

24BE 

38CB 

248E 

38CB 

24BE 

38CC 

24BE 

380E 

24BE 

38EC 

24BE 

38F4 

24BE 

3901 

24BE 

390E 

24BE 

3918 

24BE 

3926 

2488 

392A 

246E 

392A 

24BE 

392B 

24BE 

3930 

24SE 

3945 

24BE 

3940 

24BE 

395A 

24BE 

3967 

24BE 

396F 

24BE 

3977 

24C0 

397B 

24C0 

397B 

24C0 

397C 

24C0 

3996 

24C0 

3996 

24C0 

39A3 

24C0 

39B0 

24C0 

39BO 

24C0 

39CA 

24C0 

39CE 

24C0 

14:51.36 

Source 

Line 

IBM  Personal 

Computer  HASH:  Conpiler  VI. CO 

REM 

**** 

*** 

REM 

OUTPUT 

:  'TEXTS'  THING  VARIABLE 

«•* 

REM 

•••* 

**• 

REM 

RESERVED  LINE 

REM 

**•* 

NUMBERS 

:  8001-8500 

*** 

REN 

•*•*** 

■DECODE  THE  HEADER  ONLY 

8001  POINTER  »  0 

RECORDPTR  ■  VARPTR(SHEETREC(0)} 

FOR  J8000  s  1  TO  21 

8002  TEXTS*  T£XT$+CHR$(P£EKTR£COROPTR  ♦  POINTER)) 
P0IMTER*P0IMTeR+1 

NEXT  J8000 

PROGRAMS*  LEFTS<TEXTS,3) 

BATCHS*  MIDS(T£XTS,4,3) 

SERIALS*  MIDS(TEXTS,7,4) 

RUNIDS*  M10S(TEXTS,11,1) 

FORMS*  HIDS(TEXTS,12,2) 

POCKETS*  MI0S(TEXTS,14,1) 

SCANERR 1S*MI0S(TEXTS,16,2) 
SCANERR2S*MIDS(TEXTS,18,2) 
SCANERR3S*MIDS<TEXTS,20,2) 

GOTO  3500 

8050  REM  CHECK  FOR  ENO  OF  JOB/END  OF  BATCH 

IF  PROGRAMS  •  PGMIDS  THEN  GOTO  8500 
LPRINT  STRINGS(80,"*") 

LPRINT 

LPRINT  "RECORDS  PROCESSED  ...  ";SERIALS 


LPRINT  "STARTED  AT  .  ";BTIMES 

LPRINT  "ENDED  AT  .  ", -TIMES 

LPRINT  CHRS(12) 

GOTO  30000 


8070  REM  CHECK  FOR  SCANNER  ERRORS 

IF  POCKETS  *  "  "  GOTO  8500 
LPRINT  LITHOS; 

LPRINT  "  ...  SCANNER  ERRORS  : 

LPRINT  SCANERRIS;”  /  "; 

LPRINT  SCANERRZS;"  /  "; 

LPRINT  SCANERR3S 

LN=LM*1 

GOTO  999 

8100  REM  PRINT  THE  HEADER  VARIABLES  ON  THE  TUBE.... 
LOCATE  5,1:PRINT  "PROGRAM  ";PROGRAMS; 

PRINT  "  BATCH  ";BATCHS; 

PRINT  "  RUN  ";RUNIDS; 

PRINT  "  FORM  ", -FORMS; 

PRINT  "  POCKET  POCKETS 


GOTO  8500 
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Offset  Date  Source  Line  IBM  Personal  ronfuter  BASIC  Coni|>ilpr  VI  .00 


39CE  24C0  8200  REM  DECODE  THE  RESPONSE  POSITIONS 

39CF  24C0  POINTER  »  21 

3906  24C0  RECOROPTR  «  VARPTR(SHEETREC(0)) 

390D  24C0  FOR  J8000  >  22  TO  RECOROLENGTH 


39EA 

24C2 

8202 

TEXTS  »  TEXTS+CMRS(PEEK(RECOfiOPTH  ♦  POINTER)) 

3A08 

24C2 

POINTERsPOINTERrI 

3A10 

24C2 

NEXT 

J8000 

3A21 

24C2 

3A21 

24C2 

8S00 

RETURN 

3A24 

24C2 

3A24 

24C2 

3A24 

24C2 

9000  REM  SINCLUDE:  • RACSOOOO . SUB < 

INCLUDE  THE  SCANNER  CONTROL  SUB 

3A25 

24C2 

REM 

3A25 

24C2 

REM 

AMBULATORY  CARE  DATA  BASE  13  APR  85 

**«* 

3A25 

24C2 

REM 

SKIP  COLE 

***« 

3A25 

24C2 

REM 

PROGRAM  NAME 

:  RACS9000.SUB 

•«** 

3A25 

24C2 

REM 

**** 

SCANNER  PROGRAM  * 

:  ALL 

3A2S 

24C2 

REM 

«*«* 

FUNCTION 

:  THIS  SUBROUTINE  MODULE 

3A25 

24C2 

REM 

•**« 

CONTROLS  THE  SCANNER  I/O 

3A25 

24C2 

REM 

«««« 

•  ••* 

3A25 

24C2 

REM 

«*•« 

INPUT/OUTPUT 

:  REFER  TO  THE  ASYNCHRONOUS 

*«*« 

3A25 

24C2 

REM 

COMMUNICATIONS  MANUAL  AND  THE 

3A25 

24C2 

REM 

***• 

PRE-RELEASED  SOFTWARE  GUIDE 

*«** 

3A25 

24C2 

REM 

«*•« 

«*«* 

3A25 

24C2 

REM 

«*««««•« 

3A25 

24C2 

REM 

«*«« 

RESERVED  LINE 

**•* 

3A25 

24C2 

REM 

NUMBERS 

:  9001-9100 

♦  *** 

3A25 

24C2 

REM 

*««***s 

3A25 

24C2 

3A25 

24C2 

3A25 

24C2 

REM 

kirir** 

3A25  24C2  REM  ••••  SUBROUTINE  9001  ■  PROTOCOL  SETUP  FOR  SCANNER 


3A25 

24C2 

REM 

ARGUMENTS;  PRESET  ...  SEE 

BELOW  ••••• 

3A25 

24C2 

REM 

3A25 

24C2 

9001 

REM 

3A26 

24C2 

PROTOCOLEO)  =  9600 

'BAUD  RATE 

3A2D 

24C2 

PROTOCOLED  =  78 

■PARITY  ESEE  PAGE  4-8  OF  MANUAL) 

3A34 

24C2 

PROTOCOLE2)  =  8 

■DATA  BITS 

3A3B 

24C2 

PROTOCOLE3)  =  1 

•STOP  BITS 

-A42 

24C2 

PR0T0C0LE4)  =  2 

•RS-232  PORT 

3A49 

24C2 

PROTOCOLES)  =  0 

•WRITE  TIME-OUT 

3A50 

24C2 

PR0T0C0LE6)  =  0 

•READ  TIME-OUT 

3A57 

24C2 

3A57 

24C2 

ERRSTATS  =  SPACE$(60) 

3A63 

24C2 

ARGPTR  =  VARPTREPROTOCOLEO)) 

3A6A 

24C4 

CALL  SETUP  EARGPTR, ERRSTATS) 

3A78 

24C4 

ERRMSGS^"" 

3A34 

24C4 

IF  ASCEERRSTATt)  <>  64  THEN  ERRMSC$="SETUP  ERROR  "♦ERRSTATS 

3AA0 

24C4 

GOTO  9100 

"AA4 

24C4 

3aa4 

24C4 

REM 

3AA4 

2404 

REM 

•**•  SUGPOOi'NE  9010  -  CONTROL 

OPTIONS  FOR  SCANNER  ***** 

3AA4 

24  C4 

REM 

***•  ARGUMENi;:  CNTRLOPT 

HACPGEM  page  52 

GENERAL  FORM  DESTRING/DECQOE  PROGRAM  07-CS-87 

H:51:J6 


Offset 

Data 

Source 

Line 

IBM  Personal  Computer  HASIC  Compiler  VI. uO 

3AA4 

24C4 

REM 

CNTRLOPT  *  1  *  START  SCANNER  (SI) 

3AA4 

24C4 

REM 

***•  CNTRLOPT  =  2  »  STOP  SCANNER  (SO) 

3AA4 

24C4 

REM 

****  CNTRLOPT  •  3  >  TERMINATE  COMMUNICATIONS  TO  SCANNER  (DC3) 

3AA4 

24C4 

REM 

CNTRLOPT  S  4  =  CLEAR  TRANSPORT  PATH  (DC2) 

3AA4 

24C4 

REM 

••••  CNTRLOPT  =  5  =  SELECT  PRIMARY  STACKER  “SI" 

3AA4 

24C4 

REM 

*•••  CNTRLOPT  »  6  »  SELECT  SECONDARY  STACKER  "32“ 

3AA4 

24C4 

REM 

•***  CNTRLOPT  «  7  *  POSITIVE  RESPONSE/SELECT  SCANNER  (0C1) 

3AA4 

24C4 

REM 

CNTRLOPT  «  8  •  REQUEST  STATUS  (ESC) 

3AA4 

24C4 

REM 

3AA4 

24C4 

9010 

REM 

3AAS 

24C4 

ERRSTATt  *  SPACE$(60) 

3AB1 

24C4 

CALL  CNTROL  (CNTRLOPT, ERRSTATt) 

3AC2 

24C4 

ERRMSG$="" 

3ACE 

24C4 

IF  ASC(ERRSTAT$)  <>  64  THEN  ERRMSC$:"CONTROL  ERROR  "^-ERRSTATS 

3AE7 

24C4 

GOTO  9100 

3AEB 

24C4 

3AEB 

24C4 

REM 

3AEB 

24C4 

REM 

***•  SUBROUTINE  9020  -  SCAN  SHEET  CALL 

3AEB 

24C4 

REM 

*«** 

3AEB 

24C4 

REM 

***•  ARGUMENTS:  REAOTYPE 

3AEB 

24C4 

REM 

*•••  REAOTYPE  »  2  »  REQUEST  NEW  DOCUMENT  FROM  SCANNER 

3AEB 

24C4 

REM 

REAOTYPE  *  3  *  RETRANSMIT  CURRENT  DOCUMENT 

3AEB 

24C4 

REM 

«**• 

***** 

3AEB 

24C4 

REM 

*•••  ARGUMENTS:  RECORDLENGTH 

***** 

3AEB 

24C4 

REM 

NUMERIC  VARIABLE  SET  TO  THE  NUMBER  OF  CHARACTERS  TO  BE 

***** 

3AE3 

24C4 

REM 

•••»  TRANSMITTED 

3AEB 

24C4 

REM 

3AEB 

24C4 

9020 

REM 

3AEC 

24C4 

ERRSTATS  =  SPACEt(60) 

3AF8 

24C4 

RECORDPTR  =  VARPTR(SHEETREC(0)) 

3AFF 

24C4 

CALL  SCAN  (REAOTYPE, RECORDLENGTH, RECORDPTR, ERRSTATS) 

3B18 

24C4 

ERRMSGts"" 

3821 

24C4 

IF  MID$(ERRSTATt,14,3)  »  "415»  THEM  ERRMSG$»"ESC’’ 

3842 

24C4 

GOTO  9100 

3846 

24C4 

3846 

24C4 

REM 

3846 

24C4 

REM 

*•••  SUBROUTINE  9030  -  TRANSPORT  PRINT  CALL 

3846 

24C4 

REM 

**** 

3846 

24C4 

REM 

ARGUMENTS:  PRINTPOS 

3846 

24C4 

REM 

***•  NUMERIC  VARIABLE  INDICATING  THE  STARTING  PRINT  POSITION 

3846 

24C4 

REM 

VALUES  =  0  THRU  90 

3846 

24C4 

REM 

**** 

3846 

24C4 

REM 

•***  ARGUMENTS:  PSTRINGS 

***** 

3846 

24C4 

REM 

****  TEXT  TO  BE  PRINTED  ON  THE  FORM 

3846 

24C4 

REM 

**** 

3846 

24C4 

REM 

*»»*  MOTE:  THIS  ROUTINE  HAS  MO  EFFECT  UNLESS  THE  SCAN 

3846 

24C4 

REM 

HEADER  SHEET  IS  MARKED  'PRINTER  ON' 

***** 

3846 

24C4 

REM 

3846 

24C4 

9030 

REM 

3847 

24C4 

ERRSTATt  =  SPACES(60) 

3853 

24C4 

RECORDPTR  =  VARPTR(SHEETREC(0) ) 

3B5A 

24C4 

CALL  TPR 1  NT ( PR  I NTPOS , PSTR I  MGS , ERRSTATt) 

3B6F 

24CA 

IF  ASC(ERRSTATt)  <>  64  THEM  ERRMSG1="PRIMT  ERROR  "♦ERRSTATt 

3888 

24CA 

GOTO  9100 

RACPGEN 

PAGE  33 

GENERAL 

FORH  DESTRlNG/OECOpE  PROGRAM 

07-06-87 

14:51:36 

Offset 

data 

Source  Line 

IBM  Personal  Computer  IIASIC  Lonunier  VI. 00 

3B8F 

24CA 

3B8F 

24CA 

9100  RETURN 

3B92 

24CA 

REM  . END  OF  SUBROUTINE  RACS9000.SUB  . 

3S92 

24CA 

3B92 

24CA 

REM  ENO  OF  SUBROUTINES  »====«»«»*»»===s=*s====x««=s=s=»»*s==a=a»= 

3B92 

24CA 

3B92 

24CA 

25000  REM  USER  TERMINATED  INPUT...  FILE  IS  NOT  TO  BE  USED!  Ml 

3893 

24CA 

LPRINT  "USER  TERMINATED  INPUT  ..  DATA  WILL  NOT  BE  USED!" 

3B9B 

24CA 

LPRINT  “ERASING  FILE  ";0ATFIL$ 

3BA8 

24CA 

BEEP 

3BAC 

24CA 

CLS  :  PRINT  "USER  TERMINATED  INPUT  ..  DATA  WILL  NOT  BE  USEDI" 

3BB8 

24CA 

CLOSE 

3BBC 

24CA 

OPEN  OATFILS  FOR  OUTPUT  AS  #1 

38CE 

24CA 

PRINT  #1,STPINGS(RECOROLENGTH,"X“)  'VOID  THE  FIRST  RECORD 

3BE0 

24CA 

CLOSE 

3BEA 

24CA 

3BEA 

24CA 

30000  REM 

3SES 

24CA 

CLOSE 

3BE9 

24CA 

CHAIN  "RACP10" 

38F0 

24CA 

38F3 

2ACA 

22151  Bytes  Available 

8797  Bytes  Free 


0  Warning  Error<s) 
0  Severe  Error(s) 


Offset 

Oats 

Source  Line 

001A 

0002 

REM  SLINESIZE:  132 

001A 

0002 

REM  SPACESIZE:  66 

001A 

0002 

REM  STITLE:  'RACPSOO  • 

001A 

0002 

REM  SSUBTITLE:  'BAS/TMC  FORM  OESTRIRC/DECOOE  PROGRAM 

001A 

0002 

REM  SPACE 

PACE  1 
05-26-87 
09;33:12 

JBM  Personal  Conputer  BASIC  Conpiler  vl.OO 


RACPSOO 

3AS/THC  FORK  DESTRING/DECOOE  PROGRAM 


i 


Offset 

Data 

001A 

0002 

001A 

0002 

001A 

0002 

001A 

0002 

001A 

0002 

001A 

0002 

001A 

0002 

001A 

0002 

001A 

0002 

001 A 

0002 

001A 

0002 

001A 

0002 

001A 

0002 

001A 

0002 

001A 

0002 

001A 

0002 

001A 

0002 

001A 

0002 

001A 

0002 

001 A 

0002 

001A 

0002 

001A 

0002 

001A 

0002 

001A 

0002 

001A 

0002 

001A 

0002 

001A 

0002 

001A 

0002 

001A 

0002 

001A 

0002 

001A 

0002 

001A 

0002 

001A 

0002 

001A 

0002 

OOIA 

0002 

001A 

0002 

001A 

0002 

001A 

0002 

00 1A 

0002 

001A 

0002 

001A 

0002 

001A 

0002 

001A 

0002 

001A 

0002 

OIIA 

0002 

001A 

0002 

001A 

0002 

001A 

0002 

001 A 

0002 

001A 

0002 

10  lA 

0002 

00  lA 

0002 

OOIA 

0002 

0C:.> 

0002 

PAGE  2 
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REM  . . . 

REN  I  NAME:  RACPSOO  AMBULATORY  CARE  INFORMATION  SYSTEM  | 

REM  I  DATE:  16  APR  87  BAS/TNC  (BHAE)  FORM  PROGRAM  | 

REN  I  0  R  BOLLING  | 

REM  . . . 

REM  8AS/TMC  FORM  OMR  INPUT  PROGRAM 

REN 

REM  This  program  reads  the  base  form  OMR  data,  converts  various 
REM  fields,  prints  an  error  report  and  produces  the  file: 

REM 

REM  VISIT.OAT 

REM 

REM  for  input  to  FOCUS.  NOTE  THAT  THIS  FILE  IS  OPENED  FOR  APPEND 
REM  each  time  the  program  is  run.  Thus,  if  the  file  does  not  exist, 

REM  records  will  be  added  to  the  front.  If  the  file  exists,  records 
REM  will  be  added  to  the  end  of  the  current  file.  It  is  intended  that 
REM  the  FOCUS  DIALOGUE  MANAGER  ROUTINE  which  loads  the  data  will  delete 
REM  the  data  file  after  the  load  has  been  successfully  accomplished. 

REM 

REM  If  there  is  no  valid  user  logged  at  the  time  of  execution,  this 
REM  program  will  chain  to  the  logon  program  RACP05,  otherwise, 

REM  the  program  chains  to  program  RACP10  on  exit. 

REM  SINCLUOE:  'RACOIM.MOO'  REM  INCLUDE  THE  DIMENSION  DEFINITIONS 


NAME:  RACOIM.MOO  DIMENSION  DEFl  NS 

Date:  28  Feb  84  Written  by:  FU  .ole 


Dimensioned  variables  are  defined  in  this  file. 

It  is  an  included  file  so  it  cannot  be  run  in  a  stand-alone, 
mode. 


This  program  segment  may  be  modified,  but  all  files  containing 
an  include  for  this  segment  must  be  re-conpiled  in  order  to 
affect  the  changes  made  here. 

*••*••**»*•*  START  OF  DIMENSION  DEFINITION  ••••••*•*••**•»***•' 


DEFINT  A-Z 

DIM  USER$<2),HOLENGTH(12),DATEERR$(3) 
•***•***••*•  end  OF  DIMENSION  DEFINITIONS 


REM  DIMENSION  STATEMENTS  UNIQUE  TO  THIS  PROGRAM. 


DIM  SHEETRECCITSO) 

DIM  PR0T0C0L<7) 

DIM  YN$(3) 

DIM  ED.MSGS(30) 

DIM  CLINIC1.PFX$(5) 
DIM  PROVIDER. TIMES{9) 
DIM  PROCEDt(030) 

DIM  riIAGN.TX3S(160) 
DIM  HOLD?'  "  ‘ 


'{MAX.  SIZE  FOR  A  SHEET  FROM  THE  SCAMMER) 
•(ARRAY  FOR  SERIAL  BOARD  SETUP  PARAMETERS) 
'{YES/NO  ANSWERS  0*7,  1  =  Y  ,  2=M  ,  3=X) 
'(ERROR  MESSAGES  FROM  EDIT  ROUTINES) 
'(PREFIX  -H  J-  FOR  CLINIC  #1  TMC) 

'(TIME  TABLE  FOR  PROVIDERS) 

'(PROCEDURE  TABLE  FOR  BASE  FORM) 
•(DIAGNOSIS  TABLE  FOR  BASE  FORM) 

'(HOLD  AREA  FOR  SUBROUTINE  6000) 


RACP800 

BAS/TMC  FORM  DESTRINC/OECOOE  PROGRAM 


OffSRt 

001A 
OOU 
001A 
001A 
OOU 
001A 
001A 
001 A 
001 A 
001A 
001A 
001A 
001A 
001A 
001A 
001A 
001A 
001A 
001A 
001A 
001A 
001A 
OOU 
001A 
001 A 
001A 
OOU 
OOU 
OOU 
OOU 
OOU 
OOU 
OOU 
001A 
OOU 
OOU 
OOU 
OOU 
OOU 
OOU 
OOU 
OOU 
0047 
004E 
0055 
005C 
0063 
006A 
0076 
0076 
0070 
0084 
0088 
0092 
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0002 

0002 

0002 

0002 

0002 

0002 

0002 

0002 

0002 

0002 

0002 

0002 

0002 

0002 

0002 

0002 

0002 

0002 

0002 

0002 

0002 

0002 

0002 

0002 

0002 

0002 

0002 

0002 

0002 

0002 

0002 

0002 

0002 

0002 

0002 

0002 

0002 

0002 

0002 

0002 

0002 

0002 

1354 

1354 

1356 

1356 

1356 

1356 

1356 

1356 

1356 

1356 

1356 

1356 


DIM  SPECL$<09)  ‘(SPECIAL  PROGRAMS) 


REM  SINCLUDE:  'RACCMN.MOO'  REM  INCLUDE  THE  COMMON  AREA  DEFINITION 


•  NAME:  RACCMN.MOO  COMMON  AREA  DEFINITION 

*  Date:  28  Feb  84  Written  by:  Floyd  Cole 

********«*******«******«*****««****«****e********««***************i 

COMMON  AREA  DEFINITIONS  WILL  BE  HELD  IN  THIS  FILE.  IT  IS  AN 
INCLUDED  FILE  SO  IT  CANNOT  BE  RUN  IN  A  STANO*ALC»<E .  MODE. 

This  program  segment  may  be  modified,  but  all  files  containing 
an  include  for  this  segment  must  be  re*campiled  in  order  to 
affect  the  changes  made  here. 

•‘••••••‘♦•••START  OF  COMMON  OEFINlTIONS*“‘“*““““*“*‘“’ 


COMMON  FORE, BACK, BOARD, HIDE, EFORE,EBACK,BELLS  ‘BASIC  SCREEN  COLORS 


COMMON  HEADERS 
COMMON  TEXTS 
COMMON  PGM IDS 
COMMON  MOLENGTHO 
COMMON  USERSO 
•••••••••••••END 


‘21  CHARACTER  SCANNER  HEADER  INFO 
“  AIMING  CHARACTERS  FROM  SCANNER 
‘PROGRAM  OR  FORM  ID 
■DAYS  IN  THE  MONTH 

OF  COMMON  OEF1HITION‘»““““““‘“““““ 


REM  SINCLUDE:  ‘RACDEF.MOD'  REM  INCLUDE  THE  DEFAULT  DEFINITIONS 

■•««***«**«******«***«*********«***«*««*«*«*****«**«*«**************i 

“  NAME:  RACP01.DEF  DEFAULT  DEFINITIONS 

“  Date:  28  Feb  84  Written  by:  Floyd  Cole 


Variables  used  in  connon  that  have  a  default  value  on  start‘up 
will  be  held  in  this  file.  It  is  an  included  file  so  it  cannot 
be  run  in  a  stand-alone  mode.  In  normal  operation,  this  file 
should  be  'included'  in  the  main  program  only  (RACP10.BAS). 

This  program  segment  may  be  modified,  but  all  files  containing 
an  include  for  this  segment  must  be  re'compiled  in  order  to 
affect  the  changes  made  here. 


•••••••••••••START  OF  DEFAULT  DEFINITION---*-*-*' 

FORE  *  15  ‘FOREGROUND  COLOR  -  INTENSE  WHITE 

BACK  *  1  'Background  Color  =  Light  Blue 


BORO  =  4 

■BORDER 

>  RED 

HIDE  *  4 

‘ALTERNATE  COLOR 

s  RED 

EFORE*  14 

‘ERROR 

FOREGROUND 

DISPLAY 

EBACK':  0 

‘ERROR 

BACKGROUND 

DISPLAY 

BELLS  *  CHRS(7) 

‘Sound 

the  bel 1 

MOLFNCTH(I) 

C 

31 

•JAN 

MOLEN^TH(2) 

X 

28 

‘FEB  <- 

■MODIFIED  IN  SUBROUTINE  RACS5000.SU8 

HOLEHGTH(3) 

= 

31 

'MAR 

HOLENGTH(4) 

= 

30 

'APR 

MOLENGTH(5) 

= 

31 

'HAY 

RACP800 

BAS/TMC  FORM  DESTRING/OECCOE  PROGRAM 


Offset 

Data 

Source  Line 

0099 

1356 

M0L£NGTM(6) 

=  30  'JUN 

OOAO 

1356 

H0LENGTH<7} 

=  31  "JUL 

00A7 

1356 

M0LENGTH(8) 

«  31  ‘AUG 

OOAE 

1356 

M0LEHGTH(9) 

■  30  ‘SEP 

OOBS 

1356 

MOLENGTH(IO) 

»  31  'OCT 

OOBC 

1356 

M0LENG1H(11) 

»  30  'NOV 

00C3 

1356 

M0LENGTH(12) 

=  31  'DEC 

OOCA 

1356 

OOCA 

1356 

OATEERRSfO) 

a  M  N 

0003 

1356 

DATEERRS(I) 

=  "INVALID  MONTH 

1 

OOOC 

1356 

DATEERRt(2) 

=  "INVALID  OAY 

M 

00E5 

1356 

DATEERR$f3) 

>  "DAY  TOO  LARGE 

FOR  MONTH  COOED" 

OOEE 

1356 

OOEE 

1356 

MAXLENGTH 

=  80  'MAXIMUM  LENGTH  OF  OUTPUT  RECORD 

OOFS 

1358 

PADS 

CHARACTER  FOR  SHORT  RECORDS 

OOFE 

135C 

OOFE 

13SC 

1  *  J. 

**tND  OF  OEFAULr  pep 

OOFE 

135C 

OOFE 

135C 

OOFE 

135C 

KEY  OFF 

0104 

135C 

0104 

135C 

REM 

0104 

135C 

0104 

135C 

REM  ENCOUNTER  FORM  CLINIC  PREFIX  TABLE  *** 

0104 

135C 

REH  CLINIC  «1 

0104 

135C 

CLINIC1.PFX$(0)»"  '• 

0100 

135C 

CLINIC1.PFX$(1)="H" 

0116 

135C 

CLINIC1.PFX$<2)="J” 

011F 

135C 

011F 

135C 

REM  ***  ENCOUNTER  FORM  PROVIDER 

TIME  TABLE  **" 

011F 

135C 

011F 

135C 

PROVIDER. TIMES(00)="000" 

'  NO  TIME 

0128 

135C 

PROVIDER. TIME$(01)="002'' 

'  2  MINUTES 

0131 

135C 

PROVIDER.  TIME$(02)="005'' 

•  5  MINUTES 

013A 

135C 

PROVIDER. TIME$<03)="010'' 

'  10  MINUTES 

0143 

1350 

PROVIDER. TIME$(04)=«015" 

>  15  MINUTES 

014C 

1350 

PROV I DER . T I ME$( 05 ) ="020" 

•  20  MINUTES 

0155 

1350 

PROVIDER. TIME$(06)="030" 

'  30  MINUTES 

015E 

1350 

PROVIDER. TIME$(07)="045" 

'  45  MINUTES 

0167 

1350 

PROVIDER. TIME$(08)="060” 

'  1  HOUR 

C170 

1350 

PROVIDER.  TIME$<09)="999" 

'  >1  HOURS 

0179 

1350 

0179 

1350 

REH  YES/NO  TABLE 

0179 

1350 

YNt(0)=" 

''  :  YN$(1)=''Y''  : 

YN$<2)=''H''  ;  YN$(3)=''X'' 

0190 

1350 

0190 

1350 

0190 

1350 

REH  *********** 

0190 

1350 

PMUM=VAL(PGMI0$)/10 

01AF 

135E 

REM  LENGTH  OF  STRING  RECEIVED  FROM 

THE  OMR.... 

01AF 

135E 

HEADER  = 

21 

0136 

1360 

RESPOMSE= 

309 

OIDO 

1362 

RECOROLENCTH  =  HEADER  ♦  RESPONSE 

OICO 

1364 

01C8 

1364 

H .  '’ROC 

25  •  NUMBER  OF  PROCEDURES  FOR  THIS  FORM 
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05-P6-87 
09.-^^:12 

IBM  Personal  Canfutei’  RASU;  CompUer  VI. 00 


I 


RACP800 

BAS/TMC  FORM  DESTRING/OeCOOE  PROGRAM 


Offset 

Oata 

Source  Line 

OICF 

1366 

N.0tAG.C0L=4  '  NUMBER  OF  OX  COLUMNS  ON  THIS  FORM 

0106 

1368 

0106 

1368 

OATFILS  =  “VISIT.OAT"  'FILE  TO  BE  INPUT  TO  FOCUS 

010F 

136C 

BTIME$«TIMES  'SCAN  START  TIME 

OIBB 

1370 

01E8 

1370 

REM 

•**  ENCOUNTER  FORM  PROCEDURE  TABLE 

DIES 

1370 

F.NAME$»"RACPROC.''  ♦  PGMIDS 

01  f6 

1374 

OPEN  F. NAMES  FOR  INPUT  AS  «3 

0207 

1374 

FOR  I600°0  TO  30 

0200 

1374 

INPUT  #3,PROCEDS(I600) 

0225 

1376 

IF  PROCE0$(I600)="22Z2Z"  THEN  GOTO  4 

02A1 

1376 

NEXT  1600 

0250 

1376 

4 

CLOSE  #3 

0257 

1376 

0257 

1376 

REM 

ENCOUNTER  FORM  DIAGNOSIS  TABLE  **• 

0257 

1376 

F.NAMES="RACOIAG.''  ♦  PGM I OS 

0265 

1376 

OPEN  F. NAMES  FOR  INPUT  AS  #3 

0276 

1376 

FOR  1600  <  0  TO  160 

027C 

1376 

INPUT  «3,DIAGN.TA8S(I600) 

0294 

1376 

IF  DIAGN.TABS(I600):''ZZZZZ"  THEN  GOTO  6 

02B0 

1376 

NEXT  1600 

02C0 

1376 

6 

CLOSE  « 

02C7 

1376 

02C7 

1376 

REM 

INCLUDE:  'UCACAMP.OPT'  INCLUDE  THE  OUTP  UCA  VALIDATE  TABLE 

02C7 

1376 

REM 

INCLUDE:  'UCACAMP.IPT'  INCLUDE  THE  INP  UCA  VALIDATE  TABLE 

02C7 

1376 

02C7 

1376 

REM  SPACE 
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RACP800 

BAS/TMC  FOR.‘<  .eSTRING/OECOOE  PROGRAM 


Offset 

Date 

02C7 

1376 

02CC 

1376 

02D0 

1376 

0205 

1376 

0205 

1376 

0205 

1376 

02D5 

1376 

0205 

1376 

02D5 

1376 

02E7 

1376 

02E7 

1376 

02E7 

1376 

02E7 

1376 

02E7 

1376 

02F2 

1376 

02FC 

1376 

0308 

1378 

030F 

1378 

0324 

1378 

033A 

1378 

033A 

1378 

033A 

1378 

033A 

1378 

033A 

1378 

033A 

1378 

033  F 

1378 

0359 

137C 

0359 

137C 

0359 

137C 

0365 

137E 

037F 

137E 

037F 

137E 

0394 

137E 

0393 

1330 

0393 

1380 

039B 

1380 

039B 

1380 

039B 

1380 

039B 

1380 

039B 

1380 

039C 

1380 

C39C 

1380 

03A5 

1384 

03BB 

1384 

03BB 

1384 

03C0 

1384 

030C 

1388 

03OC 

1388 

03E5 

1388 

03EA 

1338 

03EF 

1338 

03F4 

1388 

C'.'6 

138c 

0  L. 

13flr 

PAGE  6 
05  Z6-87 
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Source  Line  IBM  Personal  (.onputer  HASIf.  Comftiler  VI. 00 

GOSUB  1000  ‘HAKE  SURE  THEY  ARE  LOGGED  ON 

CLS 

COSUB  7000  ‘PRINT  SCREEN  HEADING 


REM  OPEN  FILE  TO  CONTAIN  SCANNED  DATA 

****************************************************************** 

REM 


OPEN  DATFILS  FOR  APPEND  AS  #1 


**■***********************************»*****»****' 
REM  ***•  CLEAR  AND  DISPLAY  PROGRAM  SCREEN 


LPRINT  CHRt<15); 

WIDTH  “LPT1;“,160 

PAGE  >  0  :  GOSUB  7100  ‘LINE  PRINTER  HEADING 
COLOR  14 

LOCATE  11,26  ;  PRINT  "BAS/TMC  FORM  “ 

COLOR  FORE, BACK, BORO 

REM 

REM  COMMUNICATIONS  SETUP  *»• 

REM 

REM  PROTOCOL 
GOSUB  9001 

IF  ERRMSGS  >  "  "  THEN  LPRINT  ERRMSGS  :  GOTO  30000 

REM  START  SCANNER  (SI) 

CNTRLOPT  =  1  :GOSUB  9010 

IF  ERRMSGS  >  "  "  THEM  LPRINT  ERRMSGS  :  GOTO  30000 

LOCATE  22,25:PRINT  "PRESS  •ESC‘  TO  TERMINATE  SCANNING  " 
READTYPE=3  'FIRST  TIME  IN..  SCANNER  IS  STARTED.. 

REM 

REM  ***  SET  SCAN  SHEET  CALL  *• 

REM 

REM 

10  REM  -  RETURN  POINT  TO  READ  NEXT  SHEET 


A$=INKErS 

IF  AS=CHRS(27)  THEN  GOTO  25000 

GOSUB  9020  ‘SCAM  SUBROUT ’.HE  -  GET  A  RECORD 

IF  MI0S(ERRSTATS,14,3)="415"  THEM  GOTO  25000 

. . CLEAR  THE  INPUT  AREA 

GOSUB  8000  'DECODE  HEADER 

GOSUB  8050  ‘CHECK  FOR  END  OF  J08/EN0  OF  BATCH 
GOSUB  8200  'DECODE  THE  RESPONSE  POSITIONS 
LITHOS  =  MI0$<TEXTS,22,8) 

GOSin  8070  'C,-CK  FOR  SCANNER  ERRORS 

GOSUB  8100  'PRI'TT  THE  DATA  ON  THE  SCREEN 


RACP800 

BAS/TMC  FORM  DESTRING/DECOOE  PROGRAM 
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Offset 

Data 

Source  Line 

IBM  Personal  Computer  BASIC  Compiler  /I. 00 

0410 

138C 

0410 

138C 

REM  SINOLUOE:  'RAOMSOO.MOI ■  INOLUDE  THE  BAS/TMC  FORM  REFORMAT/EDIT  MOO 

0410 

138C 

REM 

0410 

1380 

REM 

***•  AMBULATORY  CARE  INFORMATION  SYSTEM  26  MAY  87 

**•« 

0410 

1380 

REM 

D  R  BOLLING 

**** 

0410 

1380 

REM 

MODULE  NAME  :  RACMaOQ.MOl 

•*** 

0410 

1380 

REM 

SCANNER  PROGRAM  #  :  BAS/TMC  (BHAE)  FORM 

**•* 

0410 

1380 

REM 

**** 

**** 

0410 

1380 

REM 

****  PURPOSE  :  REFORMAT/EDIT  THE  FORM 

**«* 

0410 

1380 

REM 

««•« 

»*«* 

0410 

1380 

REM 

0410 

1380 

REM 

*•••  RESERVED  LINE  NUMBERS  100-199 

»*** 

0410 

1380 

REM 

0410 

1380 

0410 

1380 

N.ERR  >0  'COUNTS  THE  NUMBER  OF  ERRORS 

0417 

138E 

0417 

138E 

REM 

LITHO  CODE  DONE  IN  BAS  PROGRAM 

0417 

138E 

0417 

1388 

REM 

CLINIC  ID  (PREFIX  ♦  CODE) 

0417 

138E 

100 

CL1.COOS="BHAE"  'DEFAULT  CLINIC  CODE 

0420 

1392 

TCL1.COO$="BHAE" 

0429 

1396 

0429 

1396 

REM 

...  CLINIC  CODE  WHEN  BAS  BUBBLED  ... 

0429 

1396 

IF  MIO$(TEXT$,59,2)»"  "  THEN  102 

0441 

1396 

CL1.C00$="S8"  +MID$(TEXTt,59,2) 

04S6 

1396 

0458 

1396 

REH 

...  CLINIC  CODE  WHEN  THC  COOED  ... 

0458 

1396 

102 

IF  MI0$(TEXT$,88,2)="  "  THEN  104 

0470 

1396 

CK.X=VAL(MID$<TEXT$,87,1)) 

0486 

1398 

CK.COO$=M10$(TEXT$,88,2) 

0498 

1390 

TCL1.C00$="B"  ♦  CLINICl.PFXSCCK.X)  ♦  OK. COOS 

0485 

1390 

IF  TCL1.COOS*"BJAA"  THEN  TCLl  .COO$=“BJYA'' 

04CC 

1390 

04CC 

1390 

REM 

VISIT  DATE 

04CC 

1390 

104 

CM$=MID$(DATE$,1,2)  'CURRENT  MONTH 

04DE 

13A0 

YR$=MID$(0ATE$,9,2)  'CURRENT  YEAR 

04  FO 

13A4 

X$=MID$<TEXT$,30,4)  'MONTH  AND  DAY 

0502 

13  AS 

IF  LEFT$(X$,2)<=CM$  THEN  105  'OK,  USE  THIS  YEAR 

0517 

13A8 

YR$=RIGHT$(STR$(VAL{YR$)-1),2)  'USE  LAST  YEAR 

0537 

13A8 

105 

VI0ATE$=YR$+X$ 

0545 

13A0 

'EDIT  VISIT  DATE 

0545 

13A0 

CK.5000$=VIDATE$ 

054E 

1380 

GOSUB  5000  'DATE  CHECK 

0553 

1380 

IF  RT. 5000=0  THEN  GOTO  106 

0562 

1382 

N.ERR=N.ERR>1 

056A 

1382 

EO.MSG$(H.ERR)="VISIT  DATE"  ♦  0ATEERR$<RT.5000) 

0590 

1382 

0590 

1382 

REH 

**•  PRIMARY  PROVIDER  *** 

0590 

1382 

106 

PPROV.PFX$=HID$(TEXT$,61,1)  'BAS 

05A2 

1386 

PPROV.MUM$=MID$(TEXT$,62,4)  'BAS 

0584 

138A 

TPPROV.PFX$=MIDS(TEXTt,90, 1 )  'TMC 

05C6 

138E 

TPPROV.NUM$=MIDS(TEXT$,91,4)  'TMC 

0508 

1302 

IF  PPROV.PFX$*PPROV.MUM$=''  "  THEN  8AS=0  ELSE  BAS=1 

05  FO 

1304 

IF  TPPROV.PFX$*TPPROV.MUM$="  "  THEM  TMC=0  ELSE  THC=1 

RACP800 

BAS/THC  FORM  DESTRING/DECOOE  PROGRAM 


Offset 

Data 

Source  Line 

0622 

13C6 

0622 

13C6 

IF  TPPROV.PFX$+TPPROV.NlJM$«“  ■  AMO  BAS»0  THEM  107 

064B 

13C6 

GOTO  108 

064F 

13C6 

064F 

13C6 

107 

N.ERR=N.ERR+1 

0657 

13C6 

ED.MSGS(N.ERR)«“NO  PROVIOER  CODED  FOR  BAS  OR  THC" 

0668 

13C6 

066B 

13C6 

REM 

**•  PATIENT  SSN  *** 

0668 

13C6 

108 

SSNS  >  MIDS(TEXTS,34,9) 

0670 

13CA 

0670 

13CA 

REM 

•••  FAMILY  MEMBER  PREF  **• 

0670 

13CA 

110 

FMEMPS»“20« 

0686 

13CE 

0686 

13CE 

REM 

•••  PRIMARY  PROVIDER  TIME 

0686 

13CE 

112 

X-VAL(MI0S(TEXTS,66,1)}  'BAS 

069C 

1300 

PPROV.TIMS«PROVIOER.TIMES(X)  'BAS 

06AE 

1304 

X*VAL<MI0S(TEXTS,95,1))  'TMC 

06C4 

1304 

TPPROV.TIIttsPROVIOER.TIMES(X)  'TMC 

0606 

1308 

0606 

1308 

REM 

SECOMDARY  PROVIOER 

0606 

1308 

SPR0V.PFX$=MI0S<TEXT$,67,1)  'BAS 

06E8 

130C 

SPROV.NUMSeMIOS(TEXTS,68,4)  'BAS 

06FA 

13E0 

TSPROV.PFXS*MIOS<TEXT$,96,1)  'TMC 

070C 

13E4 

TSPROV.NUMS=MIOS<TEXT$,97,4)  'TMC 

071E 

13E8 

IF  SPROV.PFX$+SPROV.MUM$=«  ••  THEM  PB=1  ELSE  PB*0 

0743 

13EA 

IF  TSPROV.PFX$+TSPROV.MUM$="  “  THEM  TPB=1  ELSE  TPB*0 

0768 

13EC 

IF  SPROV.PFXS""  "  AMO  SPROV.NUMS<>"  "  THEM  113 

078E 

13EC 

IF  SPROV.PFXSo"  "  AMO  SPROV.MlIM$="  "  THEM  113 

0784 

13EC 

IF  TSPROV.PFXSs"  «  AMO  TSPROV.NUMSo"  "  THEN  114 

OTDA 

13EC 

IF  TSPROV.PFXSo"  "  AMO  TSPROV.NUM$="  "  THEM  114 

0800 

13EC 

GOTO  115 

0804 

13EC 

0804 

13EC 

113 

N.ERR’=N.ERR  1 

080C 

13EC 

ED.MSG$<N.ERR)="BAS  PROV  2  CODE  MISSIMG  PREFIX  OR  NUMBER' 

0820 

13EC 

GOTO  115 

0824 

i3ec 

0824 

13EC 

114 

N.ERR=N.ERR  *  1 

J82C 

13EC 

ED.MSGS(N.ERR)3''TMC  PROV  2  COOE  MISSING  PREFIX  OR  NUMBER' 

0840 

13EC 

0840 

13EC 

REM 

**•  SECONDARY  PROVIOER  TIME  •** 

0840 

13EC 

115 

X=VAL(MID$<TEXT$,72,1))  'BAS 

0856 

13EC 

SPROV.TIMS>PROVIOER.TINES(X)  'BAS 

0868 

13f0 

X=VAL(MI0${TEXT$, 101,1))  'TMC 

087E 

13F0 

TSPROV . T I M$=PROV I DER . T IMESl X )  'TMC 

0890 

13F4 

REM  IS  THERE  A  TIME  ANO  NO  SEC  PROV  COOED? 

0890 

13F4 

IF  SPROV.TIM$<>"000"  AND  PB=1  THEN  116 

08B3 

13F4 

REM  IS  THERE  NO  TIME  ANO  A  SEC  PROV  COOED? 

0883 

13F4 

IF  SPROV.TIMS="000"  ANO  PB^O  THEN  117 

0806 

13F4 

REM  IS  THERE  A  TIME  AND  NO  SEC  PROV  COOED? 

OC06 

13F4 

IF  TSPROV. TIM$<>"000"  AND  TPB=1  THEN  118 

0819 

13f4 

REM  IS  THERE  NO  TIME  ANO  A  SEC  PROV  COOED? 

08F9 

13F4 

IF  TSPROV. T I M$="000"  AND  TPB=0  THEN  119 

091C 

13F4 

GOTO  120 
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Offset 

Oats 

Source  Line 

0920 

13F4 

116 

M.ERR^N.ERR  *  1 

0928 

13F4 

ED.MSGt(N.ERR)s"BAS  TIME  CODED  WITH  NO  SEC  PROV  COOED” 

093C 

13F4 

GOTO  120 

0940 

13F4 

0940 

13F4 

117 

N.ERR^N.ERR  «  1 

0948 

13F4 

ED.MSG$(N.ERR)="BAS  NO  PROV  2  TIME” 

095C 

13F4 

GOTO  120 

0960 

13F4 

0960 

13F4 

118 

N.ERR=N.ERR  *  1 

0968 

13F4 

ED.MSGS(N.ERR):"TMC  TIME  COOED  WITH  NO  SEC  PROV  COOED” 

097C 

13F4 

GOTO  120 

0980 

13F4 

0980 

13F4 

119 

N.ERR>N.ERR  +  1 

0988 

13F4 

ED.MSG$<N.ERRJ="TMC  NO  PROV  2  TIME” 

099C 

13F4 

099C 

13F4 

REM 

REASON  FOR  SECONDARY  PROVIDER  ••• 

099C 

13F4 

120 

SPROV.REA$»MID$<TEXTt,73,1)  'BAS 

09AE 

13F8 

TSPROV.REA$=MIOt(TEXT$, 102,1)  'TMC 

09C0 

13FC 

09C0 

13FC 

REM  IS  THERE  A  REAS  ANO  NO  SEC  PROV  COOED? 

09C0 

13FC 

IF  SPROV.REA$<>“  "  ANO  P8*1  THEN  121 

09E3 

13FC 

REM  IS  THERE  HO  REAS  ANO  A  SEC  PROV  COOED? 

09E3 

13FC 

IF  SPROV.REAS*”  "  ANO  P8*0  THEM  122 

OA06 

13FC 

REM  IS  THERE  A  REAS  ANO  NO  SEC  PROV  COOED? 

0A06 

13FC 

IF  TSPROV.REASo”  "  AND  TP8=1  THEN  123 

0A29 

13FC 

REM  IS  THERE  NO  REAS  AND  A  SEC  PROV  COOED? 

0A29 

13FC 

IF  TSPROV.REAS="  "  ANO  TPB=0  THEN  124 

0A4C 

13FC 

GOTO  129 

0A50 

13FC 

0A50 

13FC 

121 

H.ERR=N.ERR  +  1 

0AS8 

13FC 

ED.MSGS<N.ERR):”BAS  REASON  COOED  WITH  NO  SEC  PROV  COOED' 

0A6C 

13FC 

GOTO  129 

0A70 

13FC 

0A7O 

13fC 

122 

N.ERR^N.ERR  *  1 

0A78 

13FC 

EO.MSG$(M.ERR)=''BAS  NO  PROV  2  REASON” 

0A8C 

13FC 

GOTO  129 

0A90 

13FC 

OA90 

13FC 

123 

N.ERRsN.ERR  ♦  1 

0A98 

13FC 

EO.MSG$(N.ERR)=“TMC  REASON  COOED  WITH  NO  SEC  PROV  COOED' 

OAAC 

13FC 

GOTO  129 

OABO 

13FC 

OABQ 

13FC 

124 

H.ERRsN.ERR  ♦  1 

0AB8 

13FC 

ED.MSG$<M.ERR)=”TMC  NO  PROV  2  REASON" 

OACC 

13FC 

OACC 

13FC 

REM 

APPOINTMENT  STATUS  ••• 

OACC 

13FC 

129 

MOTSCS*"5”  'DEFAULT  IS  SICK  CALL  *  5 

OAOS 

1400 

X$=M1D$(TEXT$,43,1) 

0AE7 

1400 

IF  XS="1''  THEN  N0TSC$="4"  'WALK  IN 

OAFE 

1400 

IF  X$=''2”  THEN  N0TSC$=''1''  'SCHEDULED 

OBIS 

1400 

IF  XS="3"  THEN  NOTSC$="3"  'EMERGENCY 

0B2C 

1400 

0S2C 

1400 

REM 

**•  INJURIES  •** 

082C 

1400 

INJURt=MIDS(TEXT$,44,1) 

0B3E 

1404 

PACE  9 
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Offset 

Data 

Source  Line 

0B3E 

1A0A 

REM 

***  JOB  RELATED  VISIT 

0B3E 

1AOA 

R£LAT.VISS»“N“ 

0BA7 

1A08 

IF  MID$(TEXTS,45,1)«»1“  THEN  RELAT.VIS»»“Y" 

0B6B 

U08 

0B6a 

1A08 

REM 

•••  MIL  OMLY  DUTY  **• 

0B68 

1A08 

REM 

•••  DO  SEPARATELY  FOR  BAS  *•* 

0B68 

1A08 

MIL0TRS«"  « 

0B71 

HOC 

MILPROS="  " 

0S7a 

1A10 

MILDUTt*"  “ 

0883 

1A1A 

B.QTR$="  «  'MO  OTR  FOR  BAS 

0B8C 

1A18 

B.PRO$=“  "  'NO  PROF  FOR  BAS 

0B9S 

1A1C 

IF  BAS  *  0  THEM  133  'GO  IF  BAS  SECTION  NOT  FILLED  IN 

OBAO 

1A1C 

IF  TMC  =  0  THEN  130  'GO  IF  TMC  SECTION  NOT  FILLED  IN 

OBAB 

1A1C 

B.DUTS="3“  'MAKE  TMC  BY  DEFAULT 

OBBA 

1A20 

GOTO  133 

0BS8 

1A20 

OBBS 

1A20 

130 

X$=KI0t<TEXTt,49,1)  'GET  TMC  BUBBLE 

OBCA 

1A20 

IF  XS«“  «  THEN  GOTO  131 

08OC 

1A20 

B.0UT$="3"  'MAKE  TMC  BY  DEFAULT 

08E5 

1A20 

X$=MIP$(TEXTS,46,1)  'GET  OTHER  DUTY  BUBBLES 

0BF7 

1A20 

IF  XS=“  "  THEN  GOTO  140  'EVERYTHING  OK,  GO  ON 

0CO9 

1A20 

0C09 

1420 

N.ERR-H.ERR  ♦  1 

0C11 

1420 

ED.MSG$(N.ERR)="TMC  CONFLICT  IN  DISPOSITION  BOX" 

0C25 

1420 

GOTO  133 

0C29 

1420 

0C29 

1420 

131 

REM  HO  TMC  BUBBLE  COOED 

0C2a 

1420 

X$=MID$(TEXT$,46,1)  'GET  OTHER  DUTY  BUBBLES 

0C3C 

1420 

IF  XS="  "  THEN  B.DUT$="1"  :GOTO  140  'HAKE  DUTY  DEFAULT 

0C57 

1420 

IF  XS="3"  THEM  8.0UT$=’'4"  ELSE  8.0UT$*X$  'GIVE  PROPER  CODE 

0C7a 

1420 

8.QTR$=MID$(TEXT$,47,1) 

0C8C 

1420 

B.PRO$=MIO$(TEXT$,48,1) 

0C9E 

1420 

GOTO  140 

0CA2 

1420 

0CA2 

1420 

REM 

**•  MIL  ONLY  DUTY  ••• 

0CA2 

1420 

REM 

DO  FOR  TMC  NOW  ••• 

0CA2 

1420 

133 

X$=MID$<TEXT$,49,1)  'GET  TMC  BUBBLE 

JCBA 

1420 

IF  X$="  "  THEN  GOTO  134 

0CC6 

1420 

0CC6 

1420 

IF  BAS=1  THEN  134 

0CO1 

1420 

N.ERR=N.ERR  ♦  1 

0CO9 

1420 

ED.MSG$(N.ERR)="NO  TMC  CAN  BE  COOED  IP  MO  BAS  SECTION  COOED" 

OCED 

1420 

OCEO 

1420 

134 

XS=MID$<TEXT$,46,1)  'GET  OUTY  BUBBLES 

OCFF 

1420 

XA$=MIO$<TEXTt, 109,1)  'GET  ADMITTED  BUBBLE 

0D11 

1424 

IF  X$="  "  THEM  135  'GO  IF  NO  OUTY  COOED 

ODlF 

1424 

IF  XS="3"  THEN  MILDUTS="4"  ELSE  MILDUTS=X$  'GIVE  PROPER  CODE 

J042 

1424 

GOTO  136 

OCAA 

1424 

135 

IF  XAt="1''  THEM  M'lDIITt*"  "  -.GOTO  140  'PONT  CODE  IF  ADMITTED 

0n61 

1424 

MILDUT$="1"  tQivE  QjjY  BY  DEFAULT 

0D6A 

1424 

OL/.^A 

1424 

REM 

***  MIL  ONLY  OTRS  •** 

1424 

136 

MllGPt^M!CtfTEXTS,47,1) 
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BAS/TMC  FORM  DESTRING/DECOOE  PROGRAM 


Offset 

Data 

Source  Line 

0O7C 

1424 

REM 

MIL  ONLY  PROF  •** 

00 7C 

1424 

MI LPRO$>MI DSC  TEXTS , 48, 1 ) 

008E 

1424 

0O8E 

1424 

REM 

MOT  AVAILABLE 

0O8E 

1424 

140 

MAVAILSs"  " 

0097 

1428 

0097 

1428 

REM 

•**  SPEC  PREASSIGMED  CLINIC  ••• 

0097 

1428 

IMP.STCIS=HI0SCTEXTS,50,9) 

OOA9 

142C 

IMP.STOS«INP.STOS  ♦  MIDS<TEXTS,328,3)  'AOO  NOT  AVAIL 

ARRAY 

ODBE 

142C 

OOSUB  5700  'CONVERT  ARRAY 

0OC6 

142C 

SPE.BUFS=BUF.STOS  'UP  TO  9  TWO  DIGIT  COOES 

OOCC 

1434 

ODCC 

1434 

REM 

*•*  BAS  PROVIDER  2  AOOL  PROC  1  ••• 

OOCC 

1434 

A00P1S»"  »  :  A00P2S’>"  “  'INITIALIZE 

OOOE 

143C 

IF  BAS^O  THEN  148  'NO  NEED  TO  DO 

IF  BAS  BLANK 

OOE9 

143C 

144 

PR2PRC1S="M" 

0DF2 

1440 

IF  MID$(TEXTS,74,1)*“1''  THEN  PR2PRC1S=“Y" 

0E13 

1440 

0E13 

1440 

REM 

•••  BAS  ADDITIONAL  PROCEDURE  1 

0E13 

1440 

AD0P1S^I0S(TEXTS,75,5) 

0E2S 

1440 

IF  PRC2PRClSa''Y"  AND  PB»1  THEN  145 

0E48 

1444 

0E48 

1444 

REM 

BAS  PROVIDER  2  AODL  PROC  2  ••• 

0E48 

1444 

PR2PRC2S*“N" 

0E51 

1448 

IF  MI0$<TEXTS,80,1)«"1"  THEM  PR2PRC2Sa''Y" 

0E72 

1448 

0E72 

1448 

REM 

•**  BAS  ADDITIONAL  PROCEDURE  2  **** 

0E72 

1448 

A00P2S*MIDS( TEXTS, 81 ,5) 

0E84 

1448 

IF  PRC2PRC2S="Y"  AND  PB*1  THEM  145 

0EA7 

144C 

GOTO  148 

OEAB 

144C 

OEAB 

144C 

145 

N.ERRsN.ERR  «  1 

0EB3 

144C 

ED.MSG$(N.ERR)*"BAS  ADOL  PROC  COOED  FOR  PROV  2  BUT 

PROV2 

NOT 

CODED' 

0EC7 

144C 

0EC7 

144C 

REM 

TMC  PROVIDER  2  ADDL  PROC  1  •«* 

0EC7 

144C 

148 

TPR2PRC1S="N" 

OEDO 

1450 

IF  MI0SCTEXTS,103,1)="1"  THEN  TPR2PRC1S="Y'' 

0EF1 

1450 

0EF1 

1450 

REM 

*•*  TMC  ADDITIONAL  PROCEDURE  1  •** 

0EF1 

1450 

TADDP1S=MI0SCTEXTS, 104,5) 

0F03 

1454 

IF  TPRC2PRC1S="Y"  AND  PB^I  THEN  149 

0F26 

1458 

GOTO  ISO 

0F2A 

1458 

0F2A 

1458 

149 

N.ERR=N.ERR  *  1 

0F32 

1458 

ED.MSG$CN.ERR)="TMC  ADOL  PROC  COOED  FOR  PROV  2  BUT 

PROV2 

NOT 

COOED' 

0F46 

USB 

0F46 

1458 

REN 

***  ADMITTED  *»• 

0F46 

1458 

150 

A0MITS="M" 

0F4F 

145C 

IF  MI0S(TEXT$,109,1)*"1"  THEM  AOMITS«"Y" 

0F70 

145C 

0F7O 

145C 

REM 

EDIT  FOR  MIL  ONLY  BOX 

OF  70 

145C 

IF  A0MIT$="N"  THEM  152 

0F7E 

145C 

IF  MILOUTSs"  "  AND  MILOTRSs"  »  THEN  152 

OFAl 

145C 

PAGE 
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OFAl 
0FA2 
OFAA 
OFBE 
OFBE 
OFBE 
OFC7 
0FE8 
0FE8 
0FE8 
OFFE 
1012 
1026 
103A 
104C 
105E 
10SE 
105E 
1080 
1080 
109C 
10C8 
10OA 
100A 
100  A 
lOFO 
1104 
1118 
112C 
113E 
1150 
1150 
1150 
117F 
117F 
118E 
11BA 

nee 
iiee 
nee 
noE 
noE 
noE 
11 DE 
nE7 
IIFO 
1203 
120a 

120A 

1210 

1228 

1233 

124C 
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use 

U5C 

U5C 

U5C 

145C 

145C 

1460 

1460 

1460 

1460 

1460 

1464 

1464 

1464 

1468 

1468 

1468 

1468 

1468 

1468 

146C 

146C 

146C 

146C 

146C 

146C 

1470 

1470 

1470 

1470 

1470 

1470 

1470 

1470 

1470 

1470 

1470 

1470 

1470 

1470 

1474 

1474 

1474 

1474 

1478 

147e 

1470 

147E 

147E 

1480 

1480 

1480 

1480 


151  REH  ...  ERROR  DUTY.  OTRS  AND  ADMITTED  CANMOT  ALL  BE  CODED 
N.ERR  >  N.ERR  *  1 

E0.MSG$(N.ERR>>"0UTY  OR  OTRS  CANNOT  BE  COOED  WITH  ADMITTED" 

REH  ***  FIELD  *** 

152  FIEL0S="N" 

IF  MIDS(TEXTS,86,1)="1"  THEN  FIELD$="Y" 

REM  UNLISTED  PRIMARY  OX 

154  X*VAL(MIDS<TEXT$,161,1)) 

IF  X=0  THEN  PRIMDX$="“ 

IF  X=1  THEN  PRIMOX$="V" 

IF  X=2  THEN  PHIMOX$=«S" 

0XTMP$=M I0t<  TEXTS , 162 , 5 ) 

IF  0XTMPS="  *  THEN  GOTO  158 

REH  REMOVE  LEADING  BLANKS 

156  IF  LEFTSIDXTMPS, 1 )«“  "  THEN  0XTMP$=HIGHT$<DXTMP$.4)+“  »:GOTO  156 

158  LASTC$=RIGHTI(OXTHP$,1)  'GET  LAST  CHAR 

IF  LASTCSo"  "  AND  LASTCS<>“0"  THEN  PRIMOXS*""  'REMOVE  V  OR  S 
PRIMOXS»LEFT$(PRIMOX$+OXTMPS,S)  'GET  5  CHAR  ONLY 

REM  UNLISTED  SECONDARY  OX 

160  X"VAL(MI0S<TEXTt,167,1)) 

IF  X»0  THEN  SECDX$="" 

IF  X=1  THEN  SECOX$="V" 

IF  X=2  THEN  SECOX$="S" 

OXTMP$=M I  DSC  TEXTS , 168 , 5 ) 

IF  OXTMPSs"  "  THEN  GOTO  164 

REH  REMOVE  LEADING  BLANKS 

162  IF  LEFT$<0XTMP$,1)="  "  THEN  DXTMP$=RIGHT$(0XTMP$,4)*"  ":GOTO  162 

164  LASTC$=RIGHT$<0XTMP$,1)  'GET  LAST  CHAR 

IF  LASTCSo"  "  AND  LASTC$<>"0"  THEN  SECOXS*""  'REMOVE  V  OR  S 
SEC0XS*LEFTS(SEC0XS+0XTMPS,5)  'GET  5  CHAR  ONLY 

REM  FOLLOW  UP/RULE  OUT  •** 

166  FU.RO$=MID$(TEXTS,160,1) 

REH  *»*  EVALUATION/SERV/PROC  PROV  1 

REM  •••  TMC  ONLY  **• 

168  ESP.BUF1S*"" 

ESP.BUF2S="" 

INP.STOS=MID$(TEXTS,nO,N.PROC) 

N.STO=1 

170  X.STO=INSTR<N.STO, INP.STOS,"1") 

IF  X.ST0=0  THEM  GOTO  172  'THATS  ALL 

N.STO=X.STO  +  1  'NEXT  STARTING  POINT 

ESP.BUF1S=ESP.BUF1S  ♦  PROCEDS{X.STO)  'ADO  CODE  TO  BUFFER  BY  FIVES 
IF  H.STO  <=  LEN( INP.STOS)  THEN  GOTO  170 
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Offset 

' 

Data 

Source  Line  IBM  Personal 

Computer  BASIC  Compiler  V'.OO 

. 

1258 

1480 

REM 

EVALUATION/SERV/PROC  PROV  2 

1258 

1480 

172 

IMP.STOSsMIOSfTEXTi.llO+M.PROC.R.PROC) 

1272 

1480 

M.STO-I 

1279 

1480 

1279 

1480 

174 

X.STO»lMSTR(N.STO.INP.STOt,"1") 

1288 

1480 

IF  X.STO=0  THEN  GOTO  176  'THATS  ALL 

129A 

1480 

IF  TPB»1  THEN  175 

12A5 

1480 

N.STO>X.STO  +  1  'NEXT  STARTING  POINT 

12A0 

1480 

ESP.BUF2S°ESP.BUF2t  +  PROCEO$(X.STO)  'AOO  CODE  TO  BUFFER  BY  FIVES 

12C2 

1480 

IF  N.STO  <>  LEN(INP.STOS)  THEN  GOTO  174 

12D5 

1480 

GOTO  176 

1209 

1480 

1209 

1480 

175 

N.ERR  >  N.ERR  *  1 

12E1 

1480 

EO.MSGS(N.ERR)>“PROC  COOED  FOR  PROV  2  BUT  PROV  2  NOT  COOED” 

12F5 

1480 

12F5 

1480 

176 

T.POS  •  173 

*  12FC 

1482 

12FC 

1482 

184 

REM 

12F0 

1482 

- 

12PD 

1482 

REM 

•••  PRIMARY  DX 

12F0 

1482 

REM 

*  IF  OTHER  PRIM  OX  IS  COOED  THEN  SKIP  THIS  SECTION  • 

12F0 

1482 

186 

IF  PRIMOXSo”  “  THEM  GOTO  192 

9  ' 

130F 

1482 

X.POS»T.POS  'STARTING  POSITION 

1318 

1484 

C1SIZ:37  :  C3SIZs42  'NO.  OF  ITEMS  IN  EACH  COL 

1324 

1488 

C2SIZ”30  :  C4SIZ<40 

1332 

148C 

GOSUB  5800  'GET  POSITION 

1337 

148C 

IF  X.FIN=0  THEN  GOTO  188 

1348 

148E 

IF  RT. 5800*0  THEN  GOTO  190 

1355 

1490 

N.ERR*N.ERR  1 

1 

1350 

1490 

EO.MSGS(N.ERR)*"PRIMARY  DX  HAS  MULTIPLE  CODES" 

1371 

1490 

GOTO  190 

1375 

1490 

1375 

1490 

188 

N.ERR*N.ERR  1 

1370 

1490 

ED.MSG$(N.ERR)="PRIMARY  DX  NOT  COOED" 

1391 

1490 

1 

1391 

1490 

190 

PR IMDXS*D I AGN . TAB$(X .FIN) 

13A3 

1490 

13A3 

1490 

192 

T.POS  =  T.POS  ♦  2  *  N.DIAG.COL 

1382 

1490 

NOX  =  147 

1389 

1492 

1389 

1492 

REM 

**»  SECONDARY  DX  ••• 

■ 

1389 

1492 

194 

I  HP . STO$=M 1 0$( TEXTS , T . POS , NDX ) 

1 

13CO 

1492 

DX2.BUF$="" 

1308 

1496 

N.STO* 1 

• 

1300 

1496 

1300 

1496 

196 

X.STO*IHSTR(M.STO, INP.STOS,"1") 

13EF 

1496 

IF  X.STO=0  THEN  GOTO  197  'THATS  ALL 

-- 

13FE 

1496 

N.STO=X.STO  +  1  'NEXT  STARTING  POINT 

1 

1408 

1496 

DX2.BUFS*DX2.BUF$  +  DIAGN.TAB$(X.STO)  'ADD  CODE  TO  BUFFER  BY  FIVES 

1418 

1496 

IF  N.STO  «  LEN(INP.STOS)  THEN  GOTO  196 

142E 

1496 

197 

IF  SECDXS*”  "  THEM  GOTO  198 

1440 

1496 

OX2.BUfS=OX2.BUFS*SECDX$  'ADD  OTHER  SEC  OX  IF  THERE 

144C 

1496 

144C 

1496 

198  REM 

I 
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U40 

1496 

REN 

. END  OF  MODULE 

RACM800.M01 . 

U40 

1496 

1440 

1496 

IF  N.ERR  >  0  THEN  GOTO  997 

145C 

1496 

LPRINT  »LITHO  §  ".•LITHOS;”  . 

.  .ERRORS" 

146E 

1496 

FOR  1997  ■  1  TO  N.ERR 

147B 

1498 

LPRINT  USING  "mt  •■;I997; 

1487 

149A 

LPRINT  ««>  •';E0.MSG$(I997) 

149D 

149A 

NEXT  1997 

14AE 

149A 

LN. COUNT  >  LN. COUNT  ♦  N.ERR  * 

1 

14BA 

149C 

CNTRLOPT  =  6 

14C1 

149C 

GOSUB  9010  'REJECT  THE 

FORM 

14C6 

149C 

GOTO  998  'BYPASS  THE 

DISK  WRITER.... 

14CA 

149C 

14CA 

149C 

997 

REM  SINCLUDE:  'RACM800.M02'  REM  INCLUDE  THE  BASE  FORM  DISK  WRITER 

14CB 

149C 

REM 

14C3 

149C 

REM 

AMBULATORY  CARE  INFORMATION  SYSTEM  16  APR  87 

*••• 

14C8 

149C 

REM 

D  R  BOLLING 

14CB 

149C 

REM 

*•••  MODULE  NAME  : 

RACM800.H02 

***• 

14CB 

149C 

REM 

SCANNER  PROGRAM  «  : 

BAS/TMC  FORM 

14CB 

149C 

REM 

***• 

14CB 

149C 

REM 

PURPOSE  : 

CREATE  AMD  WRITE  THE  DISK 

ft*** 

14C3 

149C 

REM 

*«*« 

RECORD  FOR  INPUT  TO  FOCUS 

«**• 

14CB 

149C 

REM 

«««« 

ft*** 

14CB 

149C 

REM 

«*«««****«**««**«««**«******«*«««****«**'*1^*'*«****«'ft***««*«********* 

14CB 

1<.9C 

REM 

RESERVED  LINE  NUMBERS  200-299 

ft*** 

14CB 

149C 

REM 

14CB 

149c 

14C3 

149C 

REM 

BUILD  THE  OUTPUT  RECORD 

14CB 

149C 

14C3 

149C 

GOSUB  270  'BUILD 

THE  RECORD  KEY  FOR  BAS 

1400 

149C 

GOSUB  271  'BUILD 

THE  RECORD  KEY  FOR  TMC 

1405 

149C 

1405 

149C 

REM 

1405 

149C 

REM 

RECORD  TYPE  "1"  -  MAIN 

TRANSACTION 

**** 

1405 

149C 

REM 

1405 

149C 

REN  BAS  FIRST 

1405 

149C 

1405 

149C 

IF  PRV$="  "  THEN  200 

'OONT  DO  IF  NO  PROV 

14E3 

14A0 

GOSUB  272 

'BUILD  DATA  FOR  TYPE 

1  BAS 

14E8 

14A0 

RECOOTS  *P(»1I0S+"1"+RECKEY$+RECOO1$  'TRANSACTION  ID  PLUS 

RECORD 

1502 

14AC 

GOSUB  280 

1507 

14  AC 

PRINT  *1,RECOUT$ 

1512 

14AC 

1512 

14AC 

200 

REN  NOW  DO  TMC 

1513 

14AC 

1513 

14AC 

IF  TPRVS*"  "  THEN  201 

•DOMT  DO  IF  NO  PROV 

'521 

1480 

GOSUB  273 

'BUILD  DATA  FOR  TYPE 

1  TMC 

1526 

14B0 

RECOUTS  =PGHID$+"1"*TRECKEY$+REC001$  'TRANSACTION  ID  PLUS 

RECORD 

1540 

14B4 

GOSUB  280 

1545 

14B4 

PRINT  #1, RECOUTS 

1550 

14B4 

1550 

14B4 

REM 

1550 

1434 

REM 

•♦**  RECORD  TYPE  "2"  -  RECKET  PLUS  PROCEDURE  CODE 

**** 

1550 

1434 

REM 

R****** 

RACP800 

BAS/TMC  FORK  DESTRING/DECOOE  PROGRAM 
Offset  Oats  Source  Line 

1550  UB4  201  REM  BEGIN  WITH  BAS 

1551  UB4  IF  PRV$»"  «  THEM  212  'OONT  00  IF  NO  PROV 

155F  UB4  BUF1$»""  :  BUF2S»"“  ‘INITIALIZE 

1571  UBC 

1571  UBC  REM  ***  GET  ADDITIONAL  PROCEDURES  IF  ANY  **• 

1571  UBC  IF  ADOPISo"  AND  PR2PRC1$«"M'‘  THEN  8UF1S=BUF1S*A0DP1$ 

15A3  UBC  If  ADDP2$<>"  «  AND  PR2PRC2$*"N"  THEN  BUF1#=BUF1$+ADDP2S 

15DS  UBC 

15D5  UBC  IF  ADOPISo"  "  AND  PR2PRC1$="Y"  THEN  BUF2$=BUF2$+ADDP1t 

1607  UBC  IF  A0DP2$<>"  “  AND  PR2PRC2$=‘’Y"  THEN  BUF2$=8UF2$*AD0P2$ 

1639  UBC 

1639  UBC  REM  ***  PROCESS  PROV  1  PROCEDURES 

1639  UBC 

1639  UBC  IF  LEN(BUF1S)*0  THEN  GOTO  206 

164A  UBC 

164A  UBC  RPOINT=1 

1651  UBE  202  RECra2S>MID$(BUF1S,RPOINT,5) 

1664  UC2  IF  RECM2$*"  «  THEM  GOTO  204 

1676  UC2 

1676  UC2  RECOUTt*PGMIOS*"2"*RECKEYS+“1 "+860002$  ‘TRANSACTION  ID  PLUS  RECORD 

1696  UC2  GOSUB  280 

1698  UC2  PRINT  BI.RECOUTt 

16A6  UC2 

16A6  UC2  204  RPOIMT  »  RPOINT  ♦  5 

16B0  UC2  IF  RPOINT  <  LEN(BUFIS)  THEN  GOTO  202 

16C3  UC2 

16C3  UC2  REM  •••  PROCESS  PROV  2  PROCEDURES 

16C3  UC2 

16C3  UC2  206  IF  LEN(8UF2S)-0  THEN  GOTO  212 

1604  UC2 

1604  UC2  RPOINT=1 

160B  UC2  208  REC0O2S:HIDS(BUF2$,RPOINT,S) 

16EE  UC2  IF  REC002$»'‘  "  THEM  GOTO  210 

1700  UC2 

1700  UC2  REC0UT$=PGMI0$+»2'‘+RECKEY$+"2"+REC002$  ‘TRANSACTION  ID  PLUS  RECORD 

1723  UC2  GOSUB  280 

1728  UC2  PRINT  #1,REC0UT$ 

1733  UC2 

1733  UC2  210  RPOINT  =  RPOINT  ♦  5 

173D  UC2  IF  RPOINT  <  LEM<BUF2$)  THEN  GOTO  208 

1750  UC2 

1750  UC2  REM  NOW  DO  PROCECURES  FOR  TMC 

1750  UC2  212  IF  TPRV$="  "  THEN  224  ‘OONT  DO  IF  NO  PROV 

175E  UC2 

175E  UC2  REM  •••  ADO  ADDITIONAL  PROCEDURES  IF  AMY  ••• 

175E  14C2  IF  TAOOPISo"  "  AND  TPR2PRC1S="M"  THEN  ESP.BOF1$=ESP.BUF1$+TADDP1$ 

1790  UC2 

1790  UC2  IF  TADDPISO"  "  AND  TPR2PRC1$="Y"  THEN  ESP,BUF2$=ESP.BUF2S+TAD0P1S 

17C2  UC2 

17C2  UC2  REM  PROCESS  PROV  1  PROCEDURES  TMC 

17C2  UC2 

17C2  UC2  IF  LEM(ESP.BUF1$)=0  THEM  GOTO  218 

17D3  UC2 

17D3  UC2 
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17DA 

14C2 

214 

REC0O2$<M]DS(ESP.BUF1S,RPOINT,5) 

17E0 

14C2 

IF  R£C0021=“  «  THEM  GOTO  216 

17FF 

14C2 

irFF 

14C2 

RECOUT$rPGMI0»+"2“+TR£CKEYt*"1'^R£C0O2$  ■TRAMSACTIOW  10  PLUS  RECORD 

181F 

14C2 

GOSUB  280 

1824 

14C2 

PRINT  «1,RECOUTS 

182F 

14C2 

182F 

14C2 

216 

RPOINT  s  RPOINT  *  5 

1839 

14C2 

IF  RPOINT  <  LEN(ESP.BUFIS)  THEN  GOTO  214 

184C 

14C2 

184C 

14C2 

REM 

PROCESS  PROV  2  PROCEDURES  TMC  *•* 

184C 

14C2 

184C 

14C2 

218 

IF  LEN(ESP.BUF2S):0  THEN  GOTO  224 

1850 

14C2 

1850 

14C2 

RPOINT*1 

1864 

14C2 

220 

REC002S^IDS(ESP.BUF2S, RPOINT, 5) 

1877 

14C2 

IF  RECW2Sc'<  "  THEN  GOTO  222 

1889 

14C2 

1889 

14C2 

n 

A 

£COUT$=PGMI0S+"2"*TRECKE1f$»"2"+RECOO2S  'TRANSACTION  ID  PLUS  RECORD 

18AC 

14C2 

GOSUB  280 

1881 

14C2 

PRINT  *1,REC0UTS 

18BC 

14C2 

i8ec 

14C2 

222 

RPOINT  «  RPOINT  ♦  5 

18C6 

14C2 

IF  RPOINT  <  L£N<ESP.BUF2S)  THEN  GOTO  220 

1809 

14C2 

1809 

14C2 

224 

REM  END  OF  TYPE  2  RECORDS 

180A 

14C2 

180A 

14C2 

REH 

180A 

14C2 

REM 

***•  RECORD  TYPE  "3"  •  RECKEY  PLUS  SPECIFIC  PRE  CLINIC  COOES 

180* 

1402 

REN 

180A 

14C2 

REM 

OONT  DO  FOR  BAS 

180A 

14C2 

180A 

14C2 

254 

REM  •*»  00  FOR  TMC 

i80B 

14C2 

IF  TPRVS=''  "  THEN  260  'OONT  DO  IF  NO  PROV 

18E9 

14C2 

IF  LEN(SPE.BUF$):0  THEN  260 

18F6 

14C2 

18F6 

14C2 

RPOINT=1 

13FD 

14C2 

256 

X3$*MIO$<SPE.BUFt,RPOIMT,2) 

1910 

14C6 

IF  X3$="10"  THEN  REC003$="M"  :GOTO  257 

1928 

14CA 

IF  X3S="11"  THEN  REC003$*"L"  :GOTO  257 

1946 

14CA 

IF  X3$=’’12"  THEN  REC003$="X"  :GOTO  257 

1961 

14CA 

1961 

14CA 

REC003S=RIGHT$(X3$,1) 

1970 

14CA 

IF  REC003S=''  "  THEM  258 

■97E 

14CA 

197E 

14CA 

197E 

14CA 

257 

RECOUTS=PGMIO$  ♦  "3"  ♦  TRECKEYS  ♦  REC003S 

)4P8 

14CA 

COSOB  280 

1990 

14CA 

PRINT  NI.RECOUTl 

'9A8 

14CA 

19A8 

UCA 

258 

RP0INT=RP0IMT»2 

17B1 

UCA 

IF  RPOINT  <  LEN(SPE.8UFS)  THEN  256 

19C3 

UCA 

1  ;co 

UCA 

260 

REM  END  OF  T '"E  3  RECORDS 

u 

1 

-  ; 

J  RACP800 

PAGE  17 

P  BAS/TMC 

FORM  DESTRING/DECODE  PROGRAM 

05-26-87 

09:33:12 

Offset 

Data 

Source  Line 

IBM  Personal  Coeputer  BASIC  Conpiler  VI. 00 

19C1 

14CA 

19C1 

14CA 

REM 

■  19C1 

14CA 

REM 

RECORO  TYPE  “7"  -  RECKET  PLUS  SECOND  OX  CODE 

19C1 

14CA 

REM 

19C1 

14CA 

19C1 

14CA 

IF  LEN(DX2.BUFS)=0  THEN  GOTO  268 

1902 

14CA 

1902 

14CA 

RP0IMT*1 

H  1909 

14CA 

264 

RECOO7t^tD$(0X2.BUFt,RFOINT,S) 

pi  19EC 

14CE 

IF  REC007S=“  ■  THEM  GOTO  266 

1  '  19FE 

14CE 

1  ^  19f? 

14CE 

REM 

FOR  BAS  SECTION 

1  19FE 

14CE 

IF  PRV$*“  «  THEN  265  'OONT  00  IF  NO  PROV 

1  1A0C 

14CE 

RECOUTI  «PGMI01*“7"*R£CXEy$+HEC007$  'TRANSACTION  ID  7 

1  1A26 

14CE 

G0SU8  280 

■1  1A2B 

14CE 

PRINT  mi.RECOUTS 

r  1A36 

14CE 

1  1A36 

14CE 

REM 

•••  FOR  TMC  SECTION 

|.  1A3« 

14CE 

265 

IF  TPRVS*"  «  THEN  266  'OONT  DO  IF  NO  PROV 

1  1A44 

14CE 

RECOUTS  «PGMIDt+"7"+TRECKEYt+REC007S  'TRANSACTION  ID  7 

1.  1ASE 

14CE 

GOSUB  280 

!■  1A63 

14CE 

PRINT  #1, RECOUTS 

P  1A6E 

14CE 

1 

K  1A6E 

14CE 

266 

RPOINT  *  RPOINT  +  5 

1  1A78 

14CE 

IF  RPOINT  <  LEN(DX2.BUFS)  THEN  GOTO  264 

t  1A8B 

14CE 

1  1A8B 

14CE 

268 

REM  END  OF  TYPE  7  RECORDS 

8  1a8C 

14CE 

H  1A8C 

14CE 

GOTO  299 

1  1A90 

14CE 

1  1A90 

14CE 

REM 

1  1A90 

14CE 

REM 

••••  SUBROUTINE  270  -  BUILD  THE  RECORO  KEY  FOR  BAS 

1  1A90 

14CE 

REM 

1  1A90 

14CE 

270 

RECKEY$="" 

k  1A99 

14CE 

1  1A99 

14CE 

PRVt  =  PPROV.PFXS  ♦  PPROV.NUMS 

E.  1AA? 

14CE 

IF  FRVS  =  ••  "  THEH  RETURN  'OCMT  00  IF  NOT  COOED 

1  1A88 

14CE 

1  1AB8 

14CE 

REM 

CLINIC  ID  (PREFIX  ♦  COO)  »*• 

1  1AB8 

14CE 

RECKEY$=  CL  1. COOS 

L  1AC1 

14CE 

P  1AC1 

14CE 

REM 

•••  VISIT  DATE 

1  1AC1 

14CE 

RECKEYS=RECKEY$+  VIOATEf 

1  1AC0 

14CE 

1  1AC0 

14CE 

REM 

•••  PRIMARY  PROVIDER 

1  1ACD 

14CE 

RECKEYS  =  RECKEYS  +  PPROV.PFXS  ♦  PPROV.NUMS 

I  1AE0 

14CE 

P  1AE0 

14CE 

REM 

»*•  PATIENT  SSN  **• 

I  1AE0 

14CE 

RECKEYS  =  RECKEYS  ♦  SSNS 

1  1AEC 

14CE 

1  1AEC 

14CE 

REM 

***  FAMILY  MEMBER  PREF 

1  1AEC 

14CE 

RECKEYS  =  RECKEYS  +  FMEMPS 

1  1AF8 

UCE 

k  1AF8 

14CE 

REM 

LITHO  CODE  *»* 

1 

SACP800 

BAS/TNC  FORM  OESTR1NG/<>F>-ooe  PROGRAM 


PACE  18 
05  ?6-87 
n9:’lJ:1? 

Offset  Date  Source  Line  IBM  Personal  Loinxiter  BASK  lompiler  VI. 00 


1AF8 

UCE 

RECKEYS  ■  RECKEYS  *  LITHOS 

1B04 

UCE 

1B04 

UCE 

REM 

FORM  NUMBER  ••• 

1B04 

UCE 

RECKEYS  «  RECKEYS  ♦  «80" 

1B10 

UCE 

1B10 

UCE 

RETURN 

1813 

UCE 

1B13 

UCE 

REM 

1B13 

UCE 

REM 

••••  SUBROUTINE  271  -  BUILO  THE  RECORD  KEY  FOR  TMC 

1B13 

UCE 

REM 

1813 

UCE 

271 

IRECKEYSa"" 

1B1C 

UCE 

1B1C 

UCE 

TPRVS  :  TPPROV.FFXS  *  TPPROV.NUMS 

1B2A 

UCE 

IF  TPRVS  «  "  ••  THEN  RETURN  'OONT  00  IF  NOT  COOED 

1838 

UCE 

1838 

UCE 

REM 

•••  CLINIC  10  (PREFIX  ♦  COO)  ••• 

1838 

UCE 

TRECKEYS*  TCL1.C00S 

18LA 

UCE 

1B4A 

UCE 

REM 

VISIT  DATE  **• 

1844 

UCE 

TRECKEYS=TRECKEYS*  VIOATES 

1850 

UCE 

1B50 

UCE 

REM 

•••  PRIMARY  PROVIDER  ••• 

1B50 

UCE 

TRECKEYS  •  TRECKEYS  ♦  TPRVS 

1B5C 

UCE 

1B5C 

UCE 

REM 

PATIENT  SSN  *•« 

185C 

UCE 

TRECKEYS  »  TRECKEYS  ♦  SSNS 

1868 

UCE 

1868 

UCE 

REH 

FAMILY  MEMBER  PREF  ••• 

1868 

UCE 

TRECKEYS  «  TRECKEYS  ♦  FMEHPS 

1874 

UCE 

1874 

UCE 

REM 

•••  LITHO  CODE 

1874 

UCE 

TRECKEYS  »  TRECKEYS  ♦  LITHOS 

1880 

UCE 

1880 

UCE 

REM 

FORM  NUMBER  *** 

1580 

UCE 

TRECKEYS  «  TRECKEYS  ♦  "80" 

1B8C 

UCE 

1B8C 

UCE 

RETURN 

tSSF 

UCE 

1B3F 

UCE 

REM 

188F 

UCE 

REM 

**•*  SUBROUTINE  272  -  BUILO  THE  DATA  FOR  TYPE  1  BAS 

***# 

188F 

UCE 

REM 

188F 

UCE 

272 

REC001S="" 

1898 

UCE 

1898 

UCE 

REM 

VISIT  COUNT 

1898 

UCE 

REC001S  =  REC001S  ♦  "1"  'DEFAULT  COUNT  IS  1 

13A4 

UCE 

1BA4 

UCE 

REM 

•••  PRIMARY  PROV  TIME  *•* 

13A4 

UCE 

RECOOU  =  RtCOCIS  ♦  PPROV.TIMS 

isao 

UCE 

•330 

UCE 

REM 

*•*  SECONDARY  PROVIDER  •** 

iGGO 

UCE 

RECOOIS  =  RECOOIS  ♦  SPROV.PFXS  ♦  SPROV.NUMS 

1SC3 

UCE 

UCE 

REM 

*•*  GECOSOARr  PROVIDER  TIME  *** 

1SC3  UCE 


RECOOIt  -  •  SPPOV.TIMt 


FACE  19 
05-.6-87’ 
09:33:1? 

IBM  Personal  Computer  BASIC  Compiler  VI. 00 

1BCF  UCE 

1BCF  UCE  REM  •••  REASOM  FOR  SECONDARY  PROVIOER 

1BCF  UCE  RECOOIS  *  RECOOIS  +  SPROV.REAS 

1B08  UCE 

1BDB  UCE  REM  APPOINTMENT  STATUS  ••* 

1BDB  UCE  RECOOIS  »  RECOOIS  ♦  ”5"  'ALUAY  SICK  CALL  FOR  BAS 

1BE7  UCE 

1BE7  UCE  REM  •••  REFERRAL  CODE  **• 

1BE7  UCE  RECOOIS  =  RECOOIS  ♦  "  ••  'NO  REF  CODE  FOR  THIS  FORM 

1BF3  UCE 

iaF3  UCE  REM  •••  PLACE  OF  VISIT  *»• 

1Bf3  UCE  RECOOIS  =  RECOOIS  +  "  >NO  PLACE  OF  VISIT  FOR  THIS  FORM 

1BFF  UCE 

IBFF  UCE  REM  •••  JOB  RELATED  VISIT  *•* 

IBFF  UCE  RECOOIS  *  RECOOIS  ♦  RELAT.VISS 

1C0B  UCE 

1C0B  UCE  REM  •••  MIL  ONLY  DUTY  *•* 

1C0B  UCE  RECOOIS  «  RECOOIS  ♦  B.DUTS 

1C17  UCE 

1C17  UCE  REN  •••  mil  ONLY  QTRS  ••• 

1C17  UCE  RECOOIS  »  RECOOIS  ♦  B.QTRS 

1C23  UCE 

1C23  UCE  REM  MIL  ONLY  PROFILE  ••• 

1C23  UCE  RECOOIS  »  RECOOIS  ♦  8. PROS 

1C2F  UCE 

1C2F  UCE  REM  •••  NOT  AVAILABLE 

1C2F  UCE  RECOOIS  s  REC001S  ♦  "  'BLANK  FOR  BAS 

1C3B  UCE 

1C3B  UCE  REM  •••  ADMITTED  *** 

1C3B  UCE  RECOOIS  *  RECOOIS  ♦  "N"  'NO  AODMITTEO  OK  BAS 

1C47  UCE 

1C47  UCE  REM  »•*  INFIELD  **• 

1C47  UCE  RECOOIS  =  RECOOIS  ♦  FIELDS 

1C53  UCE 

1C53  UCE  REM  •••  INJURY 

1C53  UCE  RECOOIS  =  RECOOIS  ♦  INJURS 

1C5F  UCE 

1C5F  UCE  REM  •••  PURPOSE  OF  VISIT  ••• 

1C5F  UCE  RECOOIS  =  RECOOIS  ♦  "  " 

1C6B  UCE 

1C6B  UCE  REM  PRIM  FOLLOU-UP/RULE  OUT 

1C6B  UCE  RECOOIS  =  RECOOIS  ♦  FU.ROS 

1C77  UCE 

1C77  UCE  REM  **•  PRIMARY  DX  CODE 

1C77  UCE  RECOOIS  =  RECOOIS  ♦  PRIMOXS 

1C83  UCE 

tC83  UCE  RETURN 

1C86  UCE 

1C86  UCE  REM 

1C86  UCE  REM  ••••  SUBROUTINE  273  -  BUILD  THE  DATA  FOR  TYPE  1  TMC  •••* 

1C86  UCE  REM 

1C8A  UCE 

1C86  UCE  273  RECCI01S="" 

1C8F  UCE 


RACPBOO 

BAS/THC  FORM  DESTRING/OECOOE  PROGRAM 
Offset  Data  Source  Line 


■ 

V  P  .  . 

: 

RACP800 

PAGE  20 

i 

BAS/TMC 

FORM  OESTRING/OECOOE  PROGRAM 

05  26-87 

p 

09:33:1? 

1 

Offstt 

Data 

Source 

Line 

IBM  Personal  (.omputei  HASH:  VI -00 

1 

1C8f 

14CE 

REN 

•••  VISIT  COUNT  •** 

r 

1C8F 

14CE 

RECOUIS  =  RECOOIS  ♦  "I"  'DEFAULT  COUNT  IS  1 

1 

1C98 

14CE 

1 

1C9B 

14CE 

REM 

•••  PRIMARY  PROV  TIME  ••• 

1 

1C98 

14CE 

RECOOIS  =  RECOOIS  +  TPPROV.TIMS 

1 

1CA7 

14CE 

1 

1CA7 

14CE 

REM 

•••  SECONDARY  PROVIDER 

1 

1CA7 

14CE 

RECOOIS  »  RECOOIS  *  TSPROV.PFXS  *  TSPROV.NUHS 

1 

1C8A 

14CE 

k 

ICSA 

14CE 

REM 

SECONDARY  PROVIDER  TIME  •** 

P 

1C3A 

14CE 

RECOOIS  2  RECOOIS  +  TSPROV.TIMS 

1 

1CC6 

14CE 

1 

1CC6 

14CE 

REM 

•**  REASON  FOR  SECONDARY  PROVIDER 

1 

1CC6 

14CE 

RECOOIS  <  RECOOIS  *  TSPRQV.REAS 

1 

1C02 

14CE 

L 

1C02 

14CE 

REM 

APPOINTMENT  STATUS  •*» 

It 

1CD2 

14CE 

RECOOIS  3  RECOOIS  *  NOTSCS 

1CDE 

14CE 

1COE 

14CE 

REM 

*•*  REFERRAL  CODE 

1COE 

14CE 

REC001S  =  RECOOIS  ♦  «  »  i^O  REF  CODE  FOR  THIS 

FORM 

1CEA 

14CE 

1CEA 

14CE 

REM 

*•*  PLACE  OF  VISIT  ••• 

I  (• 

1CEA 

14CE 

RECOOIS  »  RECOOIS  ♦  "  "  'NO  PUCE  OF  VISIT  FOR 

THIS  FORM 

1CF6 

14CE 

1CF6 

14CE 

REM 

JOB  RELATED  VISIT  ••• 

1CF6 

14CE 

RECOOIS  =  RECOOIS  ♦  RELAT.VISS 

1D02 

14CE 

1002 

14CE 

REH 

**•  MIL  ONLY  DUTY 

■ 

1002 

14CE 

RECOOIS  -  RECOOIS  +  MI  LOUTS 

■ 

1D0E 

14CE 

1D0E 

14CE 

REM 

•••  MIL  ONLY  QTRS  *•* 

1D0E 

14CE 

RECOOIS  =  RECOOIS  ♦  HILOTRS 

1D1A 

14CE 

1D1A 

14CE 

REM 

**•  MIL  ONLY  PROFILE  »•* 

1D1A 

14CE 

RECOOIS  =  RECOOIS  ♦  MILPROS 

■ 

1026 

14CE 

'  1026 

14CE 

REM 

•••  NOT  AVAILABLE  ••• 

1026 

14CE 

RECOOIS  =  RECOOIS  ♦  NAVAILS 

1032 

14CE 

1032 

14CE 

REH 

•••  ADMITTED  ••• 

1032 

14CE 

RECOOIS  =  RECOOIS  -v  ADMITS 

■ 

o 

m 

14CE 

103E 

14CE 

REM 

INFIELD  ••• 

1D3E 

14CE 

RECOOIS  =  RECOOIS  ♦  "  "  'NO  FIELD  ON  TMC 

1D4A 

14CE 

104A 

14CE 

REM 

•••  INJURY  ••• 

1r4A 

14CE 

RECOOIS  =  RECOOIS  ♦  INJURS 

■ 

1056 

14CE 

■ 

1056 

14CE 

REH 

*•*  PURPOSE  OF  VISIT  *** 

'056 

14CE 

RECOOIS  =  RECOOIS  ♦  "  " 

1062 

14CE 

1062 

14CE 

REM 

***  PRIM  FOLLOW-UP/RULE  OUT  •** 

1CS2 

UCE 

RECOOIS  =  RFC001S  *  FU.ROS 

■ 

IC6E 

UC' 

RACP800 

BAS/THC  FORM  OESTRING/OECOOE  PROGRAM 

Offset  Data  Source  Line 

106E  UCE  REM  PRIMARY  OX  CODE  ••• 

1D6E  UCE  RECOOn  >  RECQOIS  PRIMOXS 

1D7A  UCE 

107A  UCE  RETURN 

1D7D  UCE 

1D7D  UCE  REM 

1D7D  UCE  REM  ****  SUBROUTINE  280  -  PAD  THE  RECORD  TO  MAXLENGTH  •••' 

1D7D  UCE  REM 

1D7D  UCE  280  PAO=MAXLENCTH  -  LEN(RECOUT$)  'FIND  OUT  HOU  SHORT  THE  RECORD  IS 
108B  1400  RECOUTS  •  RECOUTS  +  STRINGS(PAO,PADS)  ‘PAD  THE  RECORD  WITH  FILL  CHAR 

109E  1400  RETURN 

10A1  1400 

1DA1  1400  299  REM 

1DA2  UDO 

1DA2  1400  REM . END  OF  MODULE  RACM800.M02 . 

10A2  1400 

1DA2  1400  998  REM  CONTINUE 

10A3  1400 

10A3  1400  999  REAOTYPE  »  2 

1DAA  1400  IF  LNLCOUNT  >  48  THEN  GOSUB  7100  'PRINTER  HEADING 

10BA  1402  GOTO  10 

1DBE  1402 

108E  1402  REM  ENO  Of  SCAN/OECOOE/URITE  LOOP 

10BE  1402 

1D8E  1402  1000  REM  SINCLUOE;  'R ACS 1000. SUB'  INCLUDE  THE  VERIFY  LOGON  SUB 

lOBf  1402  REM 

10BF  1402  REM  •  NAME.-  RACS1000  LOGON  VERIFICATION  SUBROUTINE  * 

10BF  1402  REM  •  Oate:  28  Feb  84  PATIENT  REGISTRATION  PROGRAM  * 

10BF  1402  REM 

10BF  1402  REM  PATIENT  OMR  INPUT  PROGRAM  • 

1DBF  1402  REM  • 

lOBF  1402  REM  This  program  verifies  user  is  logged  on  properly.  If  there  is  no  • 

108F  1402  REM  valid  user  logged  on  at  the  time  of  execution,  this  subroutine  will* 

IDBf  1402  REM  chain  to  the  logon  program  RACP05,  otherwise  a  return  is  issued.  • 

1DBF  1402  REM 

IDBF  1402  REM  RESERVED  LINE  NUMBERS  ARE  1001  THRU  1010 

IDBF  1402  REM 

lOBf  1402  1001  OPEN  "I", 1, "RACLOG.DAT" 


1001  1402  IF  EOF(1)  THEN  1002  'MAKE  THEM  LOG  ON  FIRST 

100F  1402  INPUT  #1,USER$<1),0T$,TMS,PI0$ 

1E00  140E  IF  USERSd)  *  ""  THEN  1002  'HAKE  THEM  LOG  ON  FIRST 

1E0E  UOE  IF  USERt(l)  «  ••***•••••  THEN  1002  'MAKE  THEM  LOG  ON  FIRST 

1E1C  UOE  CLOSE  1 

1E23  UOE  SCREEN  0,1, 0,0 

1E39  UOE  COLOR  FORE, BACK, BORO 

1E4F  UOE  CLS 

1ES3  UOE  RETURN 

1ES6  UOE 


1ES6  UOE  1002  CLOSE 

1E5A  UOE  CHAIN  "RACP05" 

1E61  UOE  'xxsxx.xxsxxENO  Of  LOGON  VERIFY  SUBROUTINE  1000»*=*="=«=»«=*=»=====»=='=='= 

1E61  UOE 

1E61  UOE  2000  REM  SINCLUOE:  'RACS2000.SUB'  INCLUDE  THE  RIPLY/OELAY  SUB 

1E62  UOE  REM  *.**..«.*..*...*•.*•**.•**«***** 


PAGE  21 
05-26-87 
09:33:12 

IBM  Personal  Computer  BASIC  Compiler  VI.C 


MCPMO  pace  22 

SAS/THC  FORM  OESTRING/OECODE  PROGRAM  OS-26-87 


09:SS:12 


Offset 

Data 

Source  Line 

ISM  Personal  Compofer  HASIC  (omptief  VJ.OO 

1E62 

UOE 

REM 

•  ••« 

AMBUUTORY  CARE  DATA  BASE  13  APR  85 

1E62 

UOE 

REM 

**** 

SKIP  COLE 

*«*• 

1E62 

1AOE 

REM 

SUBROUTINE  NAME  :  RACS2000.SUa 

1E62 

14DE 

REM 

SCANNER  PROGRAM  «  ALL 

•*** 

tE62 

140E 

REN 

**** 

FUNCTION  :  THIS  SUBROUTINE  MODULE 

«**« 

1E62 

UOE 

REM 

SERVERS  AS  A  WAIT  AND  REPLY 

*•** 

1E62 

UDE 

REM 

•  «** 

ENTRY  MODULE 

•  #** 

1E62 

UOE 

REM 

INPUT  :  SINGLE  KEYBOARD  ENTRY 

•*«* 

1E62 

140E 

REN 

•«*« 

•••* 

1E62 

14DE 

REM 

OUTPUT  ;  KEYBOARD  ENTRY  -  UPPER  CASE 

1E62 

UDE 

REM 

**** 

*•** 

1E62 

UOE 

REM 

RESERVED  LINE 

1E62 

UDE 

REM 

*•«« 

NUMBERS  :  2001-2010 

**** 

1E62 

UOE 

REN 

*****•*«**♦**•••♦*•*««**«**««***«****««««*«**•*•**•*««*«••****«*•** 

1E62 

140E 

2001 

REM  REPLY  FUNCTION 

1E63 

UOE 

2002 

R£PLY$= 

INKEYS  ;  IF  REPLYS*""  THEM  2002 

1E77 

UE2 

REPLY=ASC(REPLY$) 

1E81 

UE4 

IF  REPLY  >  90  THEN  REPLYS^CHRSCREPLY  XOR  32)  ‘CONVERT  TO  CAPS 

1E9C 

UE4 

IF  REPLYt  <  “A"  OR  REPLYS  >  *2"  THEN  REPLTS«“?“ 

1EC8 

UE4 

RETURN 

1ECS 

UE4 

1ECB 

UE4 

5000 

REN  SINCLUOE:  ‘RACSSOOO.SUB •  INCLUDE  THE  DATE  EDITOR  SUB 

1ECC 

14E4 

REM 

•*«*«•**•««•«***•«««««««««*««*•*•*##*♦»**•******••#***•* 

1ECC 

UE4 

REN 

*«•« 

AMBULATORY  CARE  DATA  BASE  13  APR  85 

•••« 

1ECC 

UE4 

REM 

*«•* 

SKIP  COLE 

*••• 

1ECC 

14E4 

REM 

SUBROUTINE  NAME  :  RXXSSOOO.SUB 

1ECC 

UE4 

REM 

«««• 

SCANNER  PROGRAM  #  :  ALL 

*«•* 

1ECC 

Ue4 

REM 

«««• 

FUNCTION  ;  THIS  SUBROUTINE  MODULE 

lECC 

UE4 

REM 

*««• 

PERFORMS  A  DATE  EDIT 

**** 

1ECC 

UE4 

REM 

A-*** 

**«* 

1ECC 

UE4 

REM 

**«* 

INPUT  :  DATE  TO  BE  CHECKED  MUST  BE 

«*** 

1ECC 

UE4 

REN 

*•«* 

IN  THE  VARIABLE  NAMED 

1ECC 

UE4 

REM 

**** 

•CK.500CS' 

1ECC 

UE4 

REM 

•««« 

IN  THE  FORMAT  "YYMMDO" 

•*** 

1ECC 

UE4 

REN 

1ECC 

UE4 

REN 

OUTPUT  :  'RT.5000'  IS  THE  RETURN  CODE 

1ECC 

UE4 

REM 

**«* 

VARIABLE.  IF  THIS  VARIABLE 

1ECC 

UE4 

REM 

«**• 

CONTAINS  ANY  NUMBER  OTHER 

1ECC 

14E4 

REM 

•••« 

THAN  0,  AN  ERROR  WAS  FOUND 

*«** 

iECC 

UE4 

REM 

«*«• 

IN  THE  DATE. 

**** 

1ECC 

UE4 

REM 

***# 

*«** 

1ECC 

UE4 

REM 

**** 

RESERVED  LINE 

**** 

lECC 

UE4 

REM 

««** 

NUMBERS  :  5001-5009 

«*** 

1ECC 

UE4 

REM 

1ECC 

UE4 

RT 

.5000  =  0 

1ED3 

UE4 

CKYEAR  =  VAL(LEFT$(CK.5000$,2))  ‘YEAR  NUMERIC  VALUE 

1EE6 

UE6 

CKMONTH  =  VAL(MI0$<CK.5000S,3,2))  'MONTH  NUMERIC  VALUE 

lEFC 

UE8 

CKDAY  =  VAL(RIGHT$(CK.5000$,2))  ‘DAY  NUMERIC  VALUE 

1fOF 

UEA 

1F0F 

UEA 

IF  CKMONTH  <  1  THEN  RT. 5000=1  :  GOTO  5009 

1F25 

UEA 

IF  CKMONTH  >  12  THEN  RT. 5000=1  :  GOTO  5009 

1F3B 

UEA 

IF  CKOAY  <  1  THEN  RT. 5000=2  :  GOTO  5009 

1F')1 

UEA 

IF  CKOAY  >  31  THEN  RT. 5000=2  :  GOTO  5009 

t.67 

l4fA 

RACP800 
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OfFsec 

Oats 

Source 

Line 

IBM  Personal  Coaputer  BASIC  Compiler  VI. OC 

1F67 

UEA 

REM 

LEAP  YEAR  CHECK 

1F67 

UEA 

MOLENGTH(2>  <  28 

1F6E 

UEA 

IF  CKMONTHo  2  THEN 

GOTO  5005  'MUST  BE  FEBRUARY 

1F7D 

UEA 

IF  (CKYEAR  MOO  4)  <>  0  THEN 

GOTO  5005  ‘MUST  BE  A  LEAP  YEAR 

1F92 

UEA 

MOLENGTH(2)  «  29 

1F99 

UEA 

1F99 

UEA 

5005 

IF  CKDAY  >  MOLENGTHCCKMONTHl 

THEN  RT. 5000*3  :  GOTO  5009 

1FB8 

UEA 

IFSa 

UEA 

5009 

RETURN 

1FBB 

UEA 

1FB6 

UEA 

1FBB 

UEA 

1FBB 

UEA 

5500  REM  INCLUDE:  •RACS5500.SUB' 

INCLUDE  THE  OUTP  UCA  VALIDATE  SUB 

1FBC 

UEA 

5600  REM  INCLUDE:  ' RACSS600 . SUB • 

INCLXE  THE  INP  UCA  VALIDATE  SUB 

1FB0 

UEA 

5700  REM  SINCLUDE:  'RACSSTOO.SUB' 

Include  map  ones  to  position  no. 

1FBE 

UEA 

REM 

***** 

1FBE 

UEA 

REM 

****  AMBULATORY  CARE  DATA  BASE  29  JUL  85 

*«** 

IFBE 

UEA 

REM 

**** 

D  R  BOLLING 

**** 

1F8E 

UEA 

REM 

••••  SUBROUTINE  NAME 

:  RXXS5700.SUB 

**•« 

IFBE 

UEA 

REM 

*•••  SCANNER  PROGRAM  « 

:  ALL 

**•• 

IFBE 

UEA 

REM 

••••  FUNCTION 

:  THIS  SUBROUTINE  MODULE 

**** 

IFBE 

UEA 

REM 

•«*« 

CONVERTS  A  BINARY  ARRAY  INTO 

•*** 

IFBE 

UEA 

REM 

*««• 

TWO  CHAR  COOES. 

•*•* 

1F6E 

UEA 

REN 

•*«« 

•*** 

IFBE 

UEA 

REN 

INPUT 

:  INP.STOS  AS  STRING 

**** 

IFBE 

UEA 

REM 

«<•«* 

**** 

IFBE 

UEA 

REM 

•*** 

IFBE 

UEA 

REM 

••••  OUTPUT 

:  BUF.STOS  AS  STRING. 

•  *** 

IFBE 

UEA 

REM 

*•♦* 

IFBE 

UEA 

REM 

**** 

*••* 

IFBE 

UEA 

REN 

RESERVED  LINE 

•  •** 

IFBE 

UEA 

REM 

NUMBERS 

:  5710-5730 

**•• 

IFBE 

UEA 

REM 

IFBE 

UEA 

IFBE 

UEA 

BUF.STOS*"" 

1FC7 

UEA 

N.STO=1 

1FCE  UEA  5710  X.STO=IlilSTR<H.STO,  INP.STOS,  "1“) 

1FE0  UEA  IF  X.STO=0  THEN  GOTO  5720  'THATS  ALL 

1FEF  UEA  N.STO  •  X.STO  ♦  1  'NEXT  STARTIHG  POINT 

1FF7  UEA  X.STO  *  X.STO  ♦  100  'PAD  UITH  LEADING  ZERO 

2001  UEA  BUF.STOS  «  BUF.STOS  ♦  RIGHT$<STR$(X.STO),2) 

2017  UEA  IF  N.STO  «  LEN( INP.STOS)  THEN  GOTO  5710 

202A  UEA 

202A  UEA  5720  RETURN 

2020  UEA 

202D  UEA  REM .  END  OF  SUBROUTINE  5700  . 

2020  UEA  5800  REM  SINCLUDE:  'RACSSSOO.SUB'  INCLUDE  FOUR  COL  DX  CONVERTER 


202E 

UEA 

REM 

*•** 

k«*** 

202E 

UEA 

REH 

•  ** 

AMBULATORY 

CARE  DATA  BASE 

30  JUL  85 

*** 

202E 

UEA 

REM 

«** 

D  R  BOLLING 

**• 

2026 

UEA 

REM 

*«« 

SU8R0UTINE 

NAME 

RXXS5800.SUB 

*** 

202E 

UEA 

REM 

*«* 

SCANNER  PROGRAM  : 

AS  APPROPRIATE 

•  *• 

202E 

UEA 

REH 

FUNCTION 

THIS  SUBROUTINE 

MODULE  READS 

*** 

RACP800 
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Offset 

Data 

Source  Line 

IBM 

202E 

HE  A 

REM 

***  FOUR  COLUMNS  IN  OX  AREA  AND 

*«* 

202E 

14EA 

REH 

•••  CONVERTS  TO  A  POSITION  IN  A 

*** 

202E 

14EA 

REM 

*•*  TABLE.  AM  ERROR  CODE  IS 

*** 

202E 

14EA 

REH 

*•*  RETURNED  IF  MULTIPLE  CODES  ARE 

202E 

14EA 

REH 

•••  PRESENT. 

*** 

202E 

14EA 

REH 

*** 

*•* 

202E 

14EA 

REM 

INPUT  :  X.POS  -  STARTING  POSITION  IN 

*** 

202E 

14EA 

REM 

STRING 

*** 

202E 

14EA 

REH 

*•* 

202E 

14EA 

REM 

OUTPUT  :  X.FIM  -  table  POSITION  OF  OX 

*«« 

2028 

14EA 

REM 

RT.5800  «  1  ON  ERROR 

«*« 

202E 

HE  A 

REM 

**« 

202E 

14EA 

REM 

*•*  RESERVED  LINE  NUMBERS  :  5801  -  5699 

**• 

202E 

HE  A 

REM 

202E 

14EA 

RT.5800=:0  ‘INITIALIZE  ERROR  INDICATOR 

2035 

14EA 

X.FIN^O  ‘INITIALIZE  TABLE  OFFSET  RESULT 

203C 

HEA 

203C 

HE  A 

REM  ••  COLUMN  1  ♦* 

203C 

HEA 

X=0  ‘STARTING  POINTER 

2043 

HEA 

X.SIZ-C1S1Z 

204A 

HEC 

X.STOaVAL(MIO${TEXT$,X.POS,2)) 

2061 

HEC 

IF  X.STO^O  THEN  GOTO  5802 

2070 

HEC 

X.FINoX.STO 

2077 

HEC 

2077 

HEC 

5802 

REH  ••  COLUMN  2  •* 

2078 

HEC 

IF  C2SIZ-a  THEN  GOTO  5804 

2087 

HEC 

X=X*X.SIZ 

2092 

HEC 

X.POS=X.POS*2 

2098 

HEC 

X.SIZ*C2SIZ 

20A2 

HEC 

X.STO=VAL(MIO$(TEXT$.X,POS,2)) 

2089 

HEC 

IF  X.STO=0  THEN  GOTO  5804 

20C8 

HEC 

IF  X.FINoO  THEN  GOTO  5890  ‘ERROR  -  MULTIPLE  CODE 

2007 

HEC 

X.FIN*X.STO  ♦  X 

20E2 

HEC 

20E2 

HEC 

5804  REM  ••  COLUMN  3  ** 

20E3 

HEC 

IF  C3SI2=0  THEN  GOTO  5806 

:0F2 

HEC 

X=X+X.SIZ 

iiOFD 

HEC 

X.POS»X.POS+2 

2106 

HEC 

X.SIZ::C3SIZ 

2100 

HEC 

X.STO=VAL(MID$<TEXT$,X.POS,2)) 

2124 

HEC 

IF  X.STO=0  THEN  GOTO  5806 

2133 

HEC 

IF  X.FIMoO  THEN  GOTO  5890  ‘ERROR  -  MULTIPLE  CODE 

2142 

HEC 

X.FIM*X.STO  ♦  X 

2140 

HEC 

2140 

HEC 

5806  REM  *•  COLUMN  4  •• 

214E 

HEC 

IF  C4S1Z=0  THEN  GOTO  5808 

2150 

HEC 

X=X+X.SIZ 

-168 

HEC 

X.POS=X.POS+2 

2171 

HEC 

X.SI2=C4SIZ 

2178 

HEC 

X.ST0=VAL(MI0S(TEXTt,X.P0S,2)) 

218F 

HEC 

IF  X.ST0=0  THEN  GOTO  5808 

219E 

HEC 

IF  X.FIHoO  THEN  GOTO  5890  ‘ERROR  -  MULTIPLE  CODE 

2i;.D 

HEC 

X.FIN=X.STO  ♦  X 

RACP800 
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Offset 

Data 

Source  Line 

IBM  Personat  Computer  BASIC  Compiltr  VI. 00 

21B8 

14EC 

5808  REM 

2189 

14EC 

GOTO  5899 

2180 

14EC 

2180 

14EC 

5890  RT. 5800*1 

’ERROR  -  MULTIPLE 

COOES 

21 C4 

14EC 

21C4 

14EC 

5899  RETURN 

21C7 

14EC 

21C7 

14EC 

21C7 

14EC 

21 C7 

14EC 

21C7 

14EC 

6000  REM  SINCLUOE:  •RACS600a.SU8' 

INCLUDE  THE  INSTRING  DECODE  SUB 

21C8 

14EC 

REM 

•*«*««•«*•*•***«•••••«•*«***«•**•*«••««*«•«***••****«***«•********« 

21 C8 

14EC 

REM 

•  *** 

AMBULATORY  CARE  OATA  BASE  13  APR  85 

21 C8 

14EC 

REM 

SKIP  COLE 

21C8 

14EC 

REM 

«•«« 

SUBROUTINE  NAME 

:  Rxxs6aoo.sua 

**** 

21C8 

14EC 

REM 

SCANNER  PROGRAM  0 

:  ALL 

21 C8 

14EC 

REM 

*•** 

FUNCTION 

:  THIS  SUBROUTINE  MODULE 

***• 

21C8 

14EC 

REM 

•••« 

PERFORMS  INSTRING  SEARCH 

21C8 

14EC 

REM 

**•« 

21C8 

14EC 

REN 

INPUT 

:  STRING  TO  BE  SEARCHED  MUST 

21C8 

14EC 

REM 

BE  IN  THE  VARIABLE  NAMED  : 

21 C8 

14EC 

REM 

«««« 

•XS> 

***• 

21CS 

14EC 

REM 

21C8 

14EC 

REN 

OUTPUT 

:  'TOT'  »  TOTAL  NUMBER  OF 

**«• 

21C8 

14EC 

REM 

•••• 

HITS  IN  the  DESTRING 

•••• 

21 C8 

14EC 

REM 

'HOLOSO'  IS  THE  ARRAY 

21 C8 

14EC 

REM 

«••• 

CONTAINING  THE  NUMERIC 

*«*• 

21C8 

14EC 

REN 

VALUE  OF  THE  HIT  POSITIONS 

***• 

21C8 

14EC 

REM 

•*** 

21C8 

14EC 

REM 

»*«*** 

21 C8 

14EC 

REM 

RESERVEO  LINE 

21C8 

14EC 

REM 

NUMBERS 

:  6001-6009 

21C8 

14EC 

REM 

21 C8 

14EC 

6001 

PTR  *  INSTRiTS,"!") 

2106 

14EE 

TOT  »  0 

2100 

UFO 

WHILE 

PTR  >  0 

21E8 

UFO 

T0T«T0T+1 

21F0 

UFO 

HOLO$(TOT)  *  RIGHTS(STRS<PTR),2) 

2212 

UFO 

PTR=PTR*1 

221A 

UFO 

PTR  *  INSTRLPTR.XS, 

"1") 

222C 

UFO 

UENO 

2230 

UFO 

RETURN 

2233 

UFO 

2233 

UFO 

REM 

2233 

UFO 

/ 

2233 

UFO 

2233 

UFO 

7000 

REM  SINCLUOE:  'RACSTOOO.SUB' 

INCLUDE  THE  SCREEN  HEADER  SUB 

2234 

UFO 

REM 

2234 

UFO 

REM 

*•** 

AMBULATORY  CARE  DATA  BASE  13  APR  85 

2234 

UFO 

REM 

*••• 

SKIP  COLE 

«*«* 

2234 

UFO 

REM 

SUBROUTINE  NAME 

:  RACS7000.SUB 

«**• 

2234 

UFO 

REM 

SCANNER  PROGRAM  f 

ALL 

**** 

2234 

UFO 

REN 

**** 

FUNCTION 

:  THIS  SUBROUTINE  MODULE 

2234 

UFO 

REM 

**** 

PRINTS  THE  STANDARD  SCREEN 

**«• 

RACPSOO 
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2234 

UFO 

REM 

**«* 

HEADING. 

2234 

UFO 

REM 

INPUT  :  CONfON  VARIABLE  USERS(2) 

**** 

2234 

UFO 

REM 

SYSTEM  DATE 

•  ••« 

2234 

UFO 

REM 

**•* 

2234 

UFO 

REM 

***• 

OUTPUT 

SCREEN  HEADING 

2234 

UFO 

REM 

*«** 

*•** 

2234 

UFO 

REM 

RESERVED  LINE 

2234 

UFO 

REM 

NUMBERS  :  7001-7010 

2234 

UFO 

REM 

*«*•***•*««««*«•*•*«****««*#««**«***«•*«•*•***•*#*«»***•»**#*«••*** 

2234 

UFO 

2234 

UFO 

7001 

LOCATE 

1.1 

223E 

UFO 

PRINT  'M/.S.  ARMY  AMBUUTORT  CARE  INFORMATION  SYSTEM" 

2246 

UFO 

LOCATE 

1,65 

2253 

UFO 

PRINT  DATES; 

2258 

UFO 

LOCATE 

2,1 

2268 

UFO 

PRINT  “USER  ;  “;USER$(1) 

2275 

UFO 

RETURN 

2278 

UFO 

2278 

UFO 

7100 

REH  SINCLUOE:  •RACS7100.SUB'  INCLUDE  THE  PRINTER  HEADER  SUB 

2279 

UFO 

REM 

2279 

UFO 

REN 

#««« 

AMBULATORY  CARE  DATA 

BASE  13  APR  85 

2279 

UFO 

REH 

SNIP  COLE 

*«*• 

2279 

UFO 

REM 

•  *«« 

SUBROUTINE  NAME 

RXXS7100.SUB 

*••• 

2279 

UFO 

REM 

*«** 

SCANNER  PROGRAM  # 

ALL 

2279 

UFO 

REM 

•  ««« 

FUNCTION 

THIS  SUBROUTINE  MODULE 

•  ••« 

2279 

UFO 

REM 

**•« 

PRINTS  THE  STANDARD  HEADING 

2279 

UFO 

REM 

*««* 

ON  THE  PRINTER. 

«*•* 

2279 

UFO 

REM 

INPUT 

DATE .PAGE , PGM I 0$ , PGMT I TL$ 

**•* 

2279 

UFO 

REM 

**•* 

2279 

UFO 

REM 

OUTPUT 

PRINTER  HEADING,  LN. COUNT 

2279 

UFO 

REM 

•  **« 

2279 

UFO 

REM 

RESERVED  LINE 

2279 

UFO 

REH 

•  ••« 

NUMBERS 

7101-7110 

«**• 

2279 

UFO 

REN 

*«•«* 

2279 

UFO 

2279 

UFO 

7101 

IF  PAGE  >  0  THEM  LPRINT  CHRS(12); 

228F 

UFO 

LPRINT 

"ARMY  AMBULATORY  CARE  INFORMATION  SYSTEM _  ";PGMTITL$; 

229C 

UF4 

LPRINT 

TAB (70), -OATES 

22AF 

UFA 

PACE=PAGE*1 

22B7 

UF4 

LPRINT 

"PROGRAM  " ; PGM I OS ; TAB<  70 ) ; "PACE " ; 

2204 

UF4 

LPRINT 

USING  "«#«#"; PAGE 

22E0 

UF4 

LPRINT 

22E8 

UF4 

LN.C0UNT=3 

22EF 

UF4 

RETURN 

22F2 

UF4 

22F2 

UF4 

8000 

REM  SINCLUOE:  ■ RACS8000 . SUB •  INCLUDE  THE  DECODE  SUB  GROUP 

-2F3 

UF4 

REM 

***** 

22F3 

UF4 

REM 

**•* 

AMBULATORY  CARE  DATA 

BASE  13  APR  85 

*** 

2?F3 

UF4 

REH 

**** 

SNIP  COLE 

*** 

22F3 

UF4 

REM 

**•# 

SUBROUTINE  NAME 

RXNSeOOO.SUB 

•  ** 

22F3 

UFA 

REM 

SCANNER  PROGRAM  « 

ALL 

•  ** 

22:3 

UFA 

REM 

*•*«* 

FUNCTION 

THIS  SUBROUTINE  MODULE 

*** 

22f3 

UFA 

REM 

**** 

IS  A  GROUPING  THAT  PERFORMS 

•  *• 

22F3 

1AF4 

REM 

***• 

VARIOUS  DECODING  FUNCTIONS 

**« 
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Data 

Source  Line 

IBM  Personal  Computer  BASIC  Compiler  ''1.00 

22F3 

14F4 

REM 

**•*  ON  THE  SCANNER  DATA 

**• 

22F3 

14F4 

REM 

22F3 

14F4 

REM 

8001  -  DECODE  THE  HEADER  POSITIONS  {POINTER  0-20) 

*** 

22F3 

14F4 

REM 

••••  8050  -  CHECK  FOR  END  OF  JOB 

22F3 

14F4 

REM 

••••  8100  -  PRINT  THE  HEADER  DATA  ON  THE  SCREEN 

•** 

22F3 

14F4 

REM 

***•  8200  -  DECODE  THE  RESPONSE  POSITIONS  (POINTER  21-.. 

) 

22F3 

14F4 

REM 

****  (RETURNED  IN  TEXTS  STRING  VARIABLE) 

*** 

22F3 

14F4 

REM 

22F3 

14F4 

REM 

••••  INPUT  :  SHEET  RECORD,  RECORD  LENGTH 

*«* 

22F3 

14F4 

REM 

••• 

22F3 

14F4 

REM 

OUTPUT  :  'TEXTS'  TRING  VARIABLE 

22F3 

14F4 

REM 

*«•« 

*•* 

22F3 

14F4 

REM 

••••  RESERVED  LINE 

*•# 

22F3 

14F4 

REM 

•••*  NUMBERS  :  8001-8500 

22F3 

14F4 

REM 

22F3 

14F4 

22F3 

14F4 

■DECOOE  THE  HEADER  ONLY 

22F3 

14F4 

8001 

POINTEP  0 

22FA 

14F6 

RECOROPTR  >  VARPTR(SHEETREC(0)) 

2301 

14F8 

FOR  J8000  >  1  TO  21 

2308 

14F8 

8002 

TEXTS*  TEXTS*CHR$(PEEK(RECOROPTR  *  POINTER)) 

2326 

14F8 

POtNTER*POINTER+1 

232E 

14F8 

NEXT  J8000 

2330 

UFA 

PROGRAMS*  LEFTS(TEXTS,3) 

234C 

14FE 

BATCHS*  MI0S(TEXTS,4,3) 

23SE 

1502 

SERIALS*  MI0t(TEXT$,7,4) 

2370 

1506 

RUNIOS*  MI0S(TEXT$,11,1) 

2382 

150A 

FORMS*  MI0S(TEXT$,12,2) 

2394 

150E 

POCKETS*  MI0$(TEXTS,14.1) 

23A6 

1512 

SCANERR1S*HI0S( TEXTS, 16,2) 

2388 

1516 

SCANERR2S=MIOS(TEXTS, 18,2) 

23CA 

151A 

scamerr3s=m I os( texts, 20 , 2 ) 

23DC 

151E 

GOTO  8500 

23E0 

151E 

23E0 

151E 

8050 

REM  CHECK  FOR  END  OF  J08/END  OF  BATCH 

23E1 

151E 

IF  PROGRAMS  •  PCMIOS  THEM  GOTO  8500 

23F3 

151E 

LPRINT  STRINGSISO,"*") 

2401 

151E 

LPRINT 

2409 

151E 

LPRINT  "RECORDS  PROCESSED  ...  ".-SERIALS 

2416 

151E 

LPRINT  "STARTED  AT  .  ";BTIMES 

2423 

151E 

LPRINT  "ENDED  AT  . ".-TIMES 

2430 

151E 

LPRINT  CHRS(12) 

2438 

151E 

GOTO  30000 

243F 

151E 

243F 

1S1E 

8070 

REM  CHECK  FOR  SCANNER  ERRORS 

2440 

151E 

IF  POCKETS  *  "  "  GOTO  8500 

2452 

151E 

LPRINT  LITHOS; 

245A 

1S1E 

LPRINT  "  ...  SCANNER  ERRORS  :  "; 

2462 

151E 

LPRINT  SCANERR1S;"  / 

246F 

151E 

LPRINT  SCAMERH2S;"  / 

247C 

151E 

LPRINT  SCANERR3S 

2484 

151E 

LM=LN+I 

248C 

1520 

GOTO  999 

2490 

1520 
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8100  REM  PRINT  THE  HEADER  VARIABLES  ON  THE  TUBE. 

LOCATE  5,1:PRINT  "PROGRAM  ";PROGRAM$; 

PRINT  »  BATCH  ":BATCHS; 
PRINT  "  RUN  *;RUNI0S; 
PRINT  ■  FORM  ".-FORMS; 

PRINT  «  POCKET  ";POCKET$ 

GOTO  8500 


2342  1522 

2549  1522 

2550  1522 


8200  REM  DECODE  THE  RESPONSE  POSITIONS 
POINTER  >  21 

RECOROPTR  >  VARPTR(SHEETREC(0)) 


24F2 

1520 

FOR  J8000  «  22  TO  RECOROLENGTH 

24FF 

1522 

8202 

TEXTS  >  TEXTS+CHRS(PEEK(RECORDPTR  POINTER)) 

2510 

1522 

PCINTER=P0IMTEH+1 

2525 

1522 

NEXT  JSOOO 

2536 

1522 

2536 

1522 

8500 

RETURN 

2539 

1522 

2539 

1522 

2539 

1522 

9000  REM  SINCLUCE:  'RACSDOOO.SUB^ 

INCLUDE  THE  SCANNER  CONTROL  SUB 

2S3A 

1522 

REM 

2S3A 

1522 

REM 

«*«« 

AMBULATORY  CARE  DATA  BASE  13  APR  85 

*•** 

2S3A 

1522 

REM 

***« 

SKIP  COLE 

•*«* 

253A 

1522 

REM 

**«« 

PROGRAM  NAME 

:  RACS9000.SUB 

**•* 

253A 

1522 

REM 

SCANNER  PROGRAM  # 

:  ALL 

**** 

253A 

1522 

REM 

*«*« 

FUNCTION 

:  THIS  SUBROUTINE  MODULE 

253A 

1522 

REM 

•*#* 

CONTROLS  THE  SCAMMER  I/O 

253A 

1522 

REM 

**«« 

253A 

1522 

REM 

***« 

INPUT /OUTPUT 

;  REFER  TO  THE  ASYNCHRONOUS 

**** 

253A 

1522 

REM 

COMMUNICATIONS  MANUAL  AND  THE 

*«*% 

253A 

1522 

REM 

PRE-RELEASED  SOFTWARE  GUIDE 

253A 

1522 

REM 

**** 

2S3A 

1522 

REM 

*«*«* 

253A 

1522 

REN 

*«»* 

RESERVED  LINE 

*•** 

253A 

1522 

REM 

NUMBERS 

.-  9001-9100 

***• 

253A 

1522 

REM 

253A 

1522 

253A 

1522 

253A 

1522 

REN 

253A 

1522 

REM 

*•«* 

SUBROUTINE  9001  -  PROTOCOL  SETUP  FOR  SCANNER 

253A 

1522 

REM 

***• 

ARGUMENTS:  PRESET  ... 

SEE  BELOW 

***«• 

''53A 

1522 

REM 

***■»« 

253A 

1522 

9001 

REM 

253B 

1522 

PROTOCOL(O)  «  9600 

•BAUD  RATE 

PROTOCOL(I)  » 
PR0T0C0L<2)  « 
PR0T0C0L(3)  * 
PROTOCOL(4)  = 
PR0I0C0L(5)  = 
PROTOCOLIA'  = 


■PARITT  (SEE  PAGE  4-6  OF  MANUAL) 

'DATA  BITS 

•STOP  BITS 

•RS-232  PORT 

•WRITE  TIME-OUT 

•READ  TIME-OUT 


ERRSTATS  =  SPACE1.(60) 


RACPSOO 

BAS/THC  FORM  OESTRING/DECOOE  PROGRAM 
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Offset 

Data 

Source 

Line 

IBM  Personal  Confxjter  BASIC  Conpiler  VI. CO 

2578 

1522 

ARGPTR  »  VARPTR(PROTOCOL(0)) 

257F 

1524 

CALL  SETUP  (ARGPTR, ERRSTATS) 

2590 

1524 

ERRMSGS>'"* 

2599 

1524 

IF  ASC(ERRSTATS)  <>  64  THEN  ERRMSGS-"SETUP  ERROR  •+ERRSTATS 

25B5 

1524 

GOTO  9100 

25B9 

1524 

25B9 

1524 

REM 

25B9 

1524 

REM 

****  SUBROUTINE  9010  -  CONTROL  OPTIONS  FOR  SCANNER 

25B9 

1524 

REM 

•••*  ARGUMENTS:  CNTRLOPT 

2SB9 

1524 

REM 

*•••  CNTRLOPT  »  1  «  START  SCANNER  (SI) 

25B9 

1524 

REM 

CNTRLOPT  =  2  =  STOP  SCANNER  (SO) 

*♦«** 

25B9 

1524 

REM 

••••  CNTRLOPT  •  3  «  TERMINATE  COMMUNICATIONS  TO  SCANNER  (DC3) 

25B9 

1524 

REM 

•***  CNTRLOPT  =  4  »  CLEAR  TRANSPORT  PATH  (0C2) 

25S9 

1524 

REN 

CNTRLOPT  »  5  »  SELECT  PRIMARY  STACKER  “SI* 

2SB9 

1524 

REM 

*•••  CNTRLOPT  -  6  *  SELECT  SECONDARY  STACKER  "32" 

2SB9 

1524 

REM 

*•**  CNTRLOPT  »  7  *  POSITIVE  RESPONSE/SELECT  SCANNER  (OC1) 

2SB9 

1524 

REM 

••••  CNTRLOPT  =  8  «  REQUEST  STATUS  (ESC) 

25B9 

1524 

REM 

25B9 

1524 

9010 

REN 

25BA 

1524 

ERRSTATS  >  SPACES(60) 

25C6 

1524 

CALL  CNTROL  (CNTRLOPT, ERRSTATS) 

2507 

1524 

ERRMSGS*"" 

25E0 

1524 

IF  ASC(ERRSTATS)  <>  64  THEN  ERRMSGS="CONTROL  ERROR  •♦ERRSTATS 

25fC 

1524 

GOTO  9100 

2600 

1524 

2600 

1524 

REM 

**  *  *  AAAAm.XAAAA 

****** 

2600 

1524 

REM 

••••  SUBROUTINE  9020  -  SCAN  SHEET  CALL 

2600 

1524 

REM 

***« 

2600 

1524 

REM 

*•••  ARGUMENTS:  READTYPE 

2600 

1524 

REM 

••••  READTYPE  =  2  =  REQUEST  NEW  DOCUMENT  FROM  SCANNER 

2600 

1524 

REM 

•••*  READTYPE  *  3  =  RETRANSMIT  CURRENT  DOCUMENT 

2600 

1524 

REM 

2600 

1524 

REM 

•**•  ARGUMENTS:  RECORDLENGTH 

2600 

1524 

REM 

•••*  NUMERIC  VARIABLE  SET  TO  THE  HUMBER  OF  CHARACTERS  TO  BE 

2600 

1524 

REN 

TRANSMITTED 

2600 

1524 

REN 

»*««•« 

2600 

1524 

9020 

REM 

2601 

1524 

ERRSTATS  ^  SPACES(60) 

2600 

1524 

RECORDPTR  »  VARPTR(SHEETREC(0)) 

2614 

1524 

CALL  SCAM  (READTYPE, RECORDLENGTH, RECORDPTR, ERRSTATS) 

2620 

1524 

ERRHSGS="" 

2636 

1524 

IF  MIDS(ERRSTATS,14,3)  *  "415"  THEM  ERRHSGSs"ESC" 

2657 

1524 

GOTO  9100 

2658 

1524 

26SB 

1524 

REM 

265B 

1524 

REN 

*••*  SUBROUTINE  9030  -  TRANSPORT  PRINT  CALL 

265B 

1524 

REM 

2658 

1524 

REM 

*•••  ARGUMENTS:  PRINTPOS 

265B 

1524 

REM 

NUMERIC  VARIABLE  INDICATING  THE  STARTING  PRINT  POSITION 

265B 

1524 

REM 

VALUES  =  0  THRU  90 

265B 

1524 

REM 

**** 

265B 

1524 

REM 

••**  ARCUMEHTS:  PSTRINGS 

265B 

1524 

REM 

••*•  TEXT  TO  BE  PRINTED  ON  THE  FORM 

265B 

1524 

REM 

RACP800 

BAS/TMC  FORM  OESTRING/OECOOE  PROGRAM 


0ff8«t 

26SB 

265B 

265B 

26SB 

265C 

2668 

266F 

2684 

26A0 

26A4 

26A4 

26A7 

26A7 

26A7 

26A7 

26A7 

26A8 

26B0 

3680 

26C1 

26C0 

2601 

3663 

26F5 

26F9 

26f9 

26FA 

26FE 

2705 

2708 

22151 

1'662 

0 

0 


Data 


Source  Line 
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1524 

1524 

1524 

1524 

1524 

1524 

1524 

152A 

152A 

152A 

152A 

152A 

152A 

152A 

152A 

152A 

1S2A 

152A 

152A 

152A 

152A 

152A 

152A 

1S2A 

152A 

152A 

152A 

152A 

152A 

152a 


REM 
REM 
REM 
9030  REM 


MOTE:  THIS  ROUTINE  HAS  NO  EFFECT  UNLESS  THE  SCAM  ••••• 

HEADER  SHEET  IS  MARKED  ‘PRINTER  ON'  •••** 

«•**********«******» 


ERRSTATS  ■  SPACES(60) 

RECOROPTR  >  VARPTR(SHEETREC(0)) 

CALL  TPR 1 NT (PR  I NTPOS, PSTR 1 NGS, ERRSTATS) 

IF  ASC(ERRSTATS)  <>  64  THEN  ERRNSGS«»PR1NT  ERROR  "-rERRSTATS 
GOTO  9100 

9100  RETURN 

HEM . EMO  OF  SUSHIXJTINE  RACS9000.SUB . 

REM  END  OF  SUBROUTINES 

25000  REM  USER  TERMINATED  INPUT...  FILE  IS  NOT  TO  BE  USEOIHI 
LPRINT  ‘5JSER  TERMINATED  INPUT  ..  DATA  WILL  NOT  BE  USED)” 

LPRINT  "ERASING  FILE  «; DAT FILS 
BEEP 

CLS  :  PRINT  "USER  TERMINATED  INPUT  ..  DATA  WILL  NOT  BE  USED!" 
CLOSE 

OPEN  OAT FILS  FOR  OUTPUT  AS  #1 

PRINT  #1,STRINGS(R£COROCENGTH,"X")  ‘VOID  THE  FIRST  RECORD 
CLOSE 

30000  REM 
CLOSE 

CHAIM  "RACP10" 


Bytes  Available 
Bytes  Free 


Warning  Error(s) 
Severe  Error(s) 


offset  Data  Source  Line 


PAr-E  1 
04-29-87 
08:1E:35 

IBM  Personal  Computer  BASIC  Compiler  V1.00 


001A 

0002 

REH  $L I  RESIZE 

:  132 

001A 

0002 

REH  SPACES IZE 

:  66 

001A 

0002 

REM  STITLE:  'RACPaZO  ■ 

001A 

0002 

REM  SSUBTITLE 

:  'EKC  (DOAA)  FORM 

001A 

0002 

REH  SPACE 

RACPSZO 

EKG  (DDAA)  FORM 


i 


Offset 

Data 

Souf 

001A 

0002 

REM 

001A 

0002 

REM 

001A 

0002 

REM 

001A 

0002 

REM 

001A 

0002 

REM 

001A 

0002 

REM 

001A 

0002 

REM 

001A 

0002 

REM 

001A 

0002 

REM 

001A 

0002 

REM 

001A 

0002 

REN 

001A 

0002 

REM 

001A 

0002 

REM 

001A 

0002 

REM 

001A 

0002 

REM 

0Q1A 

0002 

REM 

001A 

0002 

REN 

001A 

0002 

REM 

001A 

0002 

REM 

001A 

0002 

REM 

001A 

0002 

REM 

001A 

0002 

REM 

001A 

0002 

REM 

001A 

0002 

REM 

001 A 

0002 

REM 

001A 

0002 

001A 

0002 

REM 

001A 

0002 

I 

001A 

0002 

• 

001A 

0002 

001A 

0002 

** 

101 A 

0002 

% 

001A 

0002 

001A 

0002 

001A 

0002 

001A 

0002 

001A 

0002 

001A 

0002 

001A 

0002 

001A 

0002 

001A 

0002 

■101 A 

0002 

001A 

0002 

OCIA 

0002 

0u1A 

0002 

001A 

0002 

001A 

0002 

REM 

001A 

0002 

CC1A 

0002 

001A 

0002 

vOIA 

0002 

001A 

0002 

OOIA 

0002 

001 A 

0002 
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NAME:  RACP820 
DATE:  14  MAR  87 
0  R  BOILING 


AMBULATORY  CARE  INFORMATION  SYSTEM 
EKG  (DDAA)  VISIT 
SHORT  FORM 


I  INCLUDES  PREFIX  TO  LITHO  FOR  EACH  PATIENT  ON  FORM 

- - - 

EKG  FORM  INPUT  PROGRAM 

This  program  reads  the  SHORT  form  OMR  data,  converts  various 
Fields,  prints  an  error  report  and  produces  the  file: 

VISIT.OAT 

for  input  to  FOCUS.  NOTE  THAT  THIS  FILE  IS  OPENED  FOR  APPEND 
each  time  the  program  is  run.  Thus,  if  the  file  does  not  exist, 
records  will  be  added  to  the  front.  If  the  file  exists,  records 
will  be  added  to  the  end  of  the  current  file.  It  is  intended  that 
the  FOCUS  DIALOGUE  MANAGER  ROUTINE  which  loads  the  data  will  delete 
the  data  file  after  the  load  has  been  successfully  accomplished. 


If  there  is  no  valid  user  logged  at  the  time  of  execution,  this 
program  will  chain  to  the  logon  program  RACP05,  otherwise, 

THE  PROGRAM  CHAINS  TO  PROGRAM  RACP10  ON  EXIT. 


REM  SINCLUOE:  'RACOIM.MOO' 


REM  INCLUDE  THE  DIMENSION  DEFINITIONS 


NAME:  RACOIM.MOO 
Date:  28  Feb  84 


DIMENSION  DEFINITIONS 
Written  by:  Floyd  Cole 


Dimensioned  variables  are  defined  in  this  file. 

It  is  an  included  file  so  it  cannot  be  run  in  a  stand-alone, 
mode. 

This  program  segment  may  be  modified,  but  all  files  containing 
an  include  for  this  segment  must  be  re- compiled  in  order  to 
affect  the  changes  made  here. 

••*••*•••**•  START  Of  DIMENSION  DEFINITION  ••••**•♦♦•••••••*••• 

DEFINT  A-Z 

DIM  USERS(2),MOLENGTK(12),OATEERR$(3) 

************  END  OF  DIMENSION  DEFINITIONS  •»***•*»*»••»••••♦*» 

DIMENSION  STATEMENTS  UNIQUE  TO  THIS  PROGRAM . 


DIM  SHEETREC(1750) 
DIM  PROTOCOL (7) 

DIM  ED.MSGS(30) 

DIM  CLINIC2.PFXt(5) 
DIM  PROCEDSdS) 


■(MAX.  SIZE  FOR  A  SHEET  FROM  THE  SCANNER) 
•(ARRAY  FOR  SERIAL  BOARD  SETUP  PARAMETERS) 
'(ERROR  MESSAGES  FROM  EDIT  ROUTINES) 
'(PREFIX  -A  B  0  F  S-  FOR  CLINIC  #2) 
•(PROCEDURE  TABLE  FOR  SHORT  FORM) 


DIM  PROVIDER. TIMfF(9)  '(PROVIDER  TIME  TABLE) 


RACP820 

EKG  (DOAA)  FORM 
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Offset 

Data 

Source  Line 

IBM  Personal  Lomputei  HASir  CoiiiF>ilec  VI.  JO 

001A 

0002 

DIM  REFC00$(12) 

'!REFERRAL  CODE  TABLE) 

OOIA 

0002 

DIM  CLIBUB$(6) 

'COTHER  UCA) 

001A 

0002 

DIM  SPECCX>$(9) 

'(SPECIFIC  PREASSIGNED  CLINIC  COOES) 

001A 

0002 

DIM  SSN.CQOSCA) 

' 

001A 

0002 

DIM  FMP.CQ0S(4) 

' 

001 A 

0002 

DIM  REF.C00S(4) 

1 

001A 

0002 

DIM  PR1.TIM$(4) 

'  .  ARRAYS  TO  HOLD  MULTIPLE  VISITS 

OOIA 

0002 

DIM  TOT.PKOCd) 

1 

OOIA 

0002 

DIM  SPE.C0DS(4) 

1 

OOIA 

0002 

DIM  rOT.SPE{4) 

1 

001A 

0002 

DIM  GR0UP1S(4,19) 

'(PATIENT/PROCEDURE  GROUP  PROV  1) 

OOIA 

0002 

DIM  HOLDS! 18) 

'(HOLD  AREA  FOR  SUBROUTINE  6000) 

OOIA 

0002 

001A 

0002 

REH 

SINCLUDE:  'RACCMN.HOO 

REM  INCLUDE  THE  COMMON  AREA  DEFINITION 

OOIA 

0002 

1 

** 

OOIA 

0002 

(• 

NAME:  RACCHN.MOO 

COMMON  AREA  DEFINITION 

* 

OOIA 

0002 

1* 

Date;  28  Feb  84 

Written  by:  Floyd  Cole 

ft 

OOIA 

0002 

1  <r*l 

ftft 

OOU 

0002 

1 

COMMON  AREA  DEFINITIONS  WILL  BE  HELD  IN  THIS  FILE.  IT  IS  AN 

OOIA 

0002 

1 

INCLUDED  FILE  SO  IT  CANNOT  BE  RUN  IN  A  STAN0*AL0NE,  MODE. 

OOU 

0002 

1 

OOU 

0002 

t 

This  program  segment 

may  be  modified,  but  all  files  containing 

OOU 

0002 

1 

an  include  for  this  segment  must  be  re*eompi(ed  in  order  to 

OOU 

0002 

1 

affect  the  changes  made  here. 

OOU 

0002 

1 

OOU 

0002 

t 

OOU 

0002 

OOU 

0002 

COMMON  FORE, BACK, BOARD 

,HIDE,EFORE,EBACK, BELLS  'BASIC  SCREEN  COLORS 

OOU 

0002 

COMMON  HEADERS 

'21  CHARACTER  SCANNER  HEADER  INFO 

OOU 

0002 

COMMON  TEXTS 

"  AIMING  CHARACTERS  FROM  SCANNER 

OOU 

0002 

COMMON  PGM  I OS 

'PROGRAM  OR  FORM  ID 

OOU 

0002 

COMMON  MOLENGTHO 

'DAYS  IN  THE  MONTH 

OOU 

0002 

COMMON  USERS!) 

OOU 

0002 

1 

COMMON  OE  F I N I T I  ON»***********»*»»***»»**»» 

OOU 

0002 

OOU 

0002 

OOU 

0002 

REM 

SINCLUDE:  'RACOEF.MOO 

'  REM  INCLUDE  THE  DEFAULT  DEFINITIONS 

OOU 

0002 

l*«f 

ft* 

OOU 

0002 

t* 

NAME:  RACP01.0EF 

DEFAULT  DEFINITIONS 

ft 

OOU 

0002 

1  * 

Date:  28  Feb  84 

Written  by:  Floyd  Cole 

ft 

OOU 

0002 

1  ** 

ft* 

OOU 

0002 

1 

Variables  used  in  coninon  that  have  a  default  value  on  start*up 

OOU 

0002 

will  be  held  in  this 

file.  It  is  an  included  file  so  it  cannot 

OOU 

0002 

be  run  in  a  stand*alone  mode.  In  normal  operation,  this  file 

OOU 

0002 

should  be  'included' 

in  the  main  program  only  (RACP10.BAS). 

OOU 

0002 

OOU 

0002 

This  program  segment 

may  be  modified,  but  all  files  containing 

OOU 

0002 

an  include  for  this  segment  must  be  re*co«ipilod  in  order  to 

OOU 

0002 

affect  the  changes  made  here. 

OOU 

0002 

OOU 

0002 

OOU 

0002 

DEFAULT  DE  F I N I T I  ON************************ 

OOU 

0002 

FORE  =  15  'FOREGROUND  COLOR  =  INTENSE  WHITE 

004  F 

1U4 

BACK  =  1  'B.ickground  Color  =  Light  Blue 

RACP820 

EKG  (ODAA)  FORM 
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Offset 

Data 

Source  Line 

I6M  Personal  Computer  BAS!r  compiler  VI. 00 

0056 

11A4 

BORO  3  4 

■BORDER  >  RED 

0050 

11A6 

HIDE  -  4 

'ALTERNATE  COLOR  >  RED 

0064 

11A6 

EFOREs  14 

■ERROR  FOREGROUND  DISPLAY 

006B 

11A6 

EBACK=  0 

■ERROR  BACKGROUND  DISPLAY 

0072 

11A6 

BELLS  >  CHRS(7} 

■Sound  the  bell 

007E 

11A6 

007E 

11A6 

MOLENGTH(I) 

St 

31  'JAN 

0085 

11A6 

HOLENGTH(2) 

St 

28  'FEB  <--HQOIFIED  IN  SUBROUTINE  RACSSOOO.SUB 

008C 

11A6 

MOLENGTH<3) 

= 

31  'MAR 

0093 

11A6 

HOLENGTH(4} 

30  'APR 

009A 

11A6 

MOLENGTH<5) 

= 

31  'MAY 

OOA1 

11A6 

HaLENGTH(6) 

X 

30  'JUN 

OOA8 

11A6 

M0LENGTH(7) 

X 

31  'JUL 

OOAF 

11A6 

MOLENCTH(8) 

X 

31  'AUG 

0006 

11A6 

MOLENGTH(9) 

= 

30  'SEP 

OOBO 

11A6 

MOLENGTH(IO) 

s 

31  ‘OCT 

00C4 

11A6 

HOLENGTHCH) 

= 

30  'NOV 

00C8 

11A6 

H0LENGTH(12) 

X 

31  'DEC 

0002 

11A6 

0002 

11A6 

OATEERRS(O) 

- 

N  If 

OOOB 

11A6 

OATEERR$<1) 

= 

"INVALID  MONTH" 

00E4 

1146 

0ATEERR$<2) 

s 

"INVALID  DAY  " 

OOEO 

11A6 

0ATEERR$(3) 

X 

"DAY  TOO  LARGE  FOR  MONTH  COOED" 

00F6 

11A6 

00F6 

11A6 

MAXLENGTH 

= 

80  'MAXIMUM  LENGTH  OF  OUTPUT  RECORD 

QOFO 

11A8 

PADS 

=  ' 

".'■  'PAD  character  FOR  SHORT  RECORDS 

0106 

11AC 

0106 

11AC 

,  OF  DEFAULT  0EFINITIOM**«»**»»»»*»«*»*»*»*»** 

0106 

11AC 

0106 

11AC 

0106 

11AC 

KET  OFF 

010C 

11AC 

01 OC 

11AC 

REM  ♦**•»•»*•»** 

01 OC 

11AC 

REM  THE  FOLLOWING  VARIABLES  ARE  UNIQUE  TO  EACH  PROGRAM  AND  MUST 

J10C 

11AC 

REM  BE  CHANGED. 

010C 

11AC 

REM  ••••**••**•* 

010C 

11AC 

PGMTITLS 

=  "1 

EKG  (ODAA)  FORM" 

0115 

11B0 

0115 

11B0 

PGMIDS  : 

"820"  'VALUE  RECEIVED  FROM  THE  SCANNER 

011E 

11B0 

■IN  HEADER  VARIABLE  'PROGRAMS' 

011E 

11B0 

011E 

11B0 

OATFILS  = 

'  "VISIT. OAT"  'FILE  TO  BE  INPUT  TO  FOCUS 

0127 

11B4 

0127 

1164 

REM  LENGTH  OF  STRING 

RECEIVED  FROM  THE  OMR.... 

1127 

1184 

HEADER  = 

21 

012E 

11B6 

RESPONS£= 

218 

0135 

11B8 

RECORDLENGTH  ' 

=  HEADER  ♦  RESPONSE 

0140 

11BA 

0’40 

11BA 

N.PROC  = 

:  18 

■  NUMBER  OF  PROCEDURES  FOR  THIS  FORM 

0147 

118C 

0147 

11BC 

REM  •«••••»****« 

■***1 

0147 

IIBC 

0U7 

11BC 

BTIMI''T.=T1HE$ 

'SCAN  START  TIME 

0140 

11C0 

I 

I 


RACP820 

EKC  (DOAA)  FOliH 
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Offset  Data  Source  Line  IBM  Personal  Coaputer  BASIC  Compiler  VI. 00 

0150  11C0  REM  OTHER  UCA  TABLE 

0150  11C0  CLIBUB$(0)»"O0AA“  :  CL1BUB${4)«<'00AF“ 

0162  11C0  CLIBUBS(1)<»D0A8«  :  CLIBUB$(5)««00AJ‘‘ 

0174  11C0  CLtBUB$(2}:»00AI<*  :  CL1BUBS(6>*'*DOAO*< 

0186  11C0  CLtBUBS<3)°"D0AN>' 

018F  11C0 

018F  11C0  REM  •••  EMCOUMTER  FORM  CLUIC  PREFIX  TABLE  ••• 

018F  11C0  REM  CLINIC  «2 

018F  11C0  CLINIC2.PFX$(0)="  " 

0198  11C0  CLINIC2.PFX$(1)="A“ 

01A1  11C0  CLINIC2.PFXS(2)«"B“ 

01AA  11C0  CLINIC2.PFX$<3)="0" 

01B3  11C0  CLINIC2.PFXS(4)>‘‘F« 

01BC  11C0  CLINIC2.PFX$(5)="S« 

01C5  IICO 

01C5  11C0  REN  PREASSIGNED  REFERRAL  COOES  ••• 

OICS  11C0  REFCOO$(1)="AAAA"  :  REFCOO$<07)='*BGYA" 

01D7  11C0  REFCOOS(2)'»ABAA'‘  :  REFCOOS(08)»''BHAA" 

01E9  11C0  REFC00$(3)»"BAAA“  :  REFCOD$(09)="BHAE" 

01FB  11C0  REFCOO$(4)»"BACA"  :  REFCOD$(10)»«fllYA“ 

0200  11CQ  REFC00$(S)<>"BAIA"  :  REFC»$(11)»"FBAC“ 

021F  11C0  REFCOO$<6)«''BBAA"  :  REFC00t(12)»“FBGA“ 

0231  11  CO 

0231  11  CO  REM  ENCOUNTER  FORM  PROCEDURE  TABLE 

0231  11C0  PROCE0S<0)*«  “  :  PROCE0$(07)  *  "93005"  :  PROCEOS(14)=  "93012" 

024C  11C0  PROCE0S<1)="93300"  :  PROCEDS(Oa)  =  "93000"  :  PROCEDS(15)=  "93015" 

0267  11CO  PROCEOS<2)="93307"  :  PROCEDS(09)  »  "93274"  ;  PROCEDS(16)=  "93018" 

0282  11C0  PROCED$(3)="93320"  ;  PROCEDS(IO)  •  "93278"  :  PROCEO$t17>=  "78419" 

0290  11C0  PROCED$(4)="93305“  :  PROCEOS(II)  =  “93798"  :  PR0CED$(18)"  "90601" 

02B8  11  CO  PROCED$(5)»"93308"  :  PROCEDS(12)  *  "93202" 

02CA  11C0  PROCE0$(6)="93010"  !  PROCEDS(13)  *  "93201" 

020C  11C0 

020C  11C0  REM  •••  PROVIDER  TIME  TABLE  ••• 

02DC  11C0  PROVIDER. TIME$(001="000"  ■  NO  TIME 

02E5  11C0  PROVIDER. TIME$(01)="002"  •  2  MINUTES 

02EE  11C0  PROVIDER. TIHE$(02)="005"  '  5  MINUTES 

02F7  11C0  PROVIDER. TIME$(03)="010"  '10  MINUTES 

0300  11C0  PROVIDER. TIME$(04)="015"  '15  MINUTES 

0309  11C0  PROVIDER. TIME$(05)="020"  '20  MINUTES 

0312  11C0  PROVIDER. TIME$(06)="030''  '30  MINUTES 

031B  11C0  PROVIDER. TIME$<07)=''040"  '40  MINUTES 

0324  11C0  PROVIDER. TIME$<08)="050"  '50  MINUTES 

032D  11C0  PROVIDER. TIMES(09)="060"  '  1  HOUR 

0336  11C0 

0336  11C0  REM  INCLUDE:  'UCABAMC.OPT'  INCLUDE  OUTPATIENT  UCA  TABLE 

0336  11C0 

0336  11C0  REM  SPACE 


IIACP820 

EKG  (DOAA)  FORH 
Offset  Oats  Source  Line 

0336  11 CO  GOSUB  1000  'MAKE  SURE  TNET  ARE  LOGGED  ON 

033B  11 CO  CLS 

033F  11C0  GOSUB  7000  'PRINT  SCREEN  HEADING 

0344  11 CO 

0344  11  CO  REH 

0344  11  CO  REM 

0344  11C0  REM 

0344  11  CO  REM 

0344  11C0 

0356  11 CO 

0356  11 CO  REM 

0356  11 CO  REM 

0356  11C0  REM 

0356  11  CO 

0361  11  CO 

036B  11  CO 

0377  11C2 

037E  11C2 

0393  11C2 

03A9  11C2 

03A9  11C2  REH 

03A9  nc2  REM 

03A9  11C2  REM 

03A9  11C2  HEM 

03A9  11C2 

03AE  11C2 

03Ca  11C6 

03Ca  11C6  REM  START  SCANNER  (SI) 

03C8  11C6  CNTRLOPT  =1  :GOSUB  9010 

0304  11C8  IF  ERRMSGS  >  «  «  THEN  LPRIHT  ERRMSCS  :  GOTO  30000 

03EE  11C8 

03EE  11C8  LOCATE  22,25:PRINT  "PRESS  'ESC  TO  TERMINATE  SCANNING  " 

0403  11C8  REA0TYPE«3  'FIRST  TIME  IN..  SCANNER  IS  STARTED.. 

040A  11CA 

040A  11CA  REM 

040A  11CA  REH  **•*  SET  SCAN  SHEET  CALL 

040A  11CA  REM 

040A  11CA  REM 

040A  11CA 

040A  11CA  10  REM  -  RETURN  POINT  TO  READ  NEXT  SHEET 

040B  11CA 

040B  11CA  A$=INXEYt 

0414  11CE  IF  A$=CHRS(27)  THEN  GOTO  25000 

0>2A  11CE 

042A  11CE  GOSUB  9020  'SCAN  SUBROUTINE  -  GET  A  RECORD 

042F  11CE  IF  MID$(ERRSTAT$,14,3)="415"  THEN  GOTO  25000 

0448  1102 

0448  1102  TEXT$= . CLEAR  THE  INPUT  AREA 

0454  11D2  COSUB  8000  'DECODE  HEADER 

J459  1102  GOSUB  8050  'CHECK  FOR  END  OF  JOB/END  OF  BATCH 

045E  1102  GOSUB  "200  'DECODE  THE  RESPONSE  POSITIONS 

0463  1102  LITHOS  =  MID$(TEXT$,22,8) 

0475  1105  GOSUB  8070  'CHECK  FOR  SCANNER  ERRORS 

C  .74  1106  GOSUB  8100  '[R:MT  THE  DATA  ON  THE  SCREEN 


COMMUNICATIONS  SETUP 

*♦****•*****•****»******♦♦****•*#*•**♦**♦***♦♦***************•***** 

PROTOCOL 
GOSUB  9001 

IF  ERRMSCS  >  "  "  THEN  LPRINT  ERRMSGS  ;  GOTO  30000 


*«****«***********«**«***«**********«**iM** *********************** 

CLEAR  AND  DISPLAY  PROGRAM  SCREEN 

****************************************************************** 

LPRINT  CHRS(15); 

WIDTH  •LPT1;“,160 

PAGE  :  0  :  GOSUB  7100  'LINE  PRINTER  HEADING 
COLOR  14 

LOCATE  11,26  ;  PRINT  "EKG  FORM  " 

COLOR  FORE, BACK, BORD 


*************************************** 


*********************** 


«•*  OPEN  FILE  TO  CONTAIN  SCANNED  DATA  *••• 

************************** •******«**•**«***«***«****«***«**«****** 


OPEN  DAT FILS  FOR  APPEND  AS  «1 


PACE  6 
04-29-87 
08:18:35 

IBM  Personal  Computer  BASIC  Cooiitler  VI, 00 


IUCP820 

EKG  (DOAA)  FORM 


Offset 

047F 
0A7F 
047F 
047F 
047F 
047F 
047F 
047F 
047F 
047F 
047F 
047F 
047F 
047F 
047F 
0486 
0486 
0486 
0486 
0486 
048F 
048F 
048F 
04A7 
0480 
04CF 
04CF 
04CF 
04E1 
04F3 
0505 
051A 
053A 
0548 
0548 
0551 
0556 
055F 
0564 
0588 
0590 
0586 
0586 
0586 
05C8 
050A 
05E8 
05E8 
05EF 
05  F6 
05  FO 
0604 
0608 
0612 


PAGE  7 
04-29-87 
06:16.35 

Oats  Source  Line  I8M  Personal  Computer  BASIC  Compiler  VI. 0' 


1106 

1106 

1106 

1106 

1106 

1106 

1106 

1106 

1106 

1106 

1106 

1106 

1106 

1106 

1106 

1106 

1108 

1106 

1108 

1108 

HOC 

HOC 

HOC 

HOC 

HOE 

HOE 

HOE 

HOE 

HE2 

HE6 

HEA 

HEA 

HEA 

HEE 

11EE 

HF2 

HF2 

HF6 

HF6 

UFA 

UFA 

UFA 

UFA 

UFA 

IIFE 

1202 

1206 

1206 

1208 

120A 

120C 

120E 

1210 

1212 


REM  SINCLUOE:  'RACM820.MO1 <  INCLUDE  THE  SHORT  FORM  REFORMAT/EOIT  MOO 


REN 

REN 

****  AMBULATORY  CARE  INFORMATION  SYSTEM  14  MAR  87 

»•***«* 

•*** 

REM 

D  R  BOLLING 

**** 

REM 

MODULE  NAME 

RACM820.M01 

*••• 

REN 

•*** 

SCANNER  PROGRAM 

»  :  820-  EKG  (DOAA)  FORM 

*«•* 

REM 

*««« 

REN 

**** 

PURPOSE 

:  REFORMAT/EOIT  THE  ENCOUNTER 

*«** 

REM 

REN 

**«« 

#**•** 

SHORT  FORM  C3MR  RECORD.  **** 

««**•««*•** •«*«**i»*«**« •««*«««*•*«*««*««*•* 

REM  ••••  RESERVED  LINE  NUMBERS  100-199 

******************************************************************* 

N.ERR  =0  'COUNTS  THE  NUMBER  OF  ERRORS 

REM  ***  LITHO  CODE  DONE  IN  BAS  PROGRAM  *** 

REM  CLINIC  ID  **• 

100  CL1.COO$="OOAA"  'DEFAULT  CLINIC  CODE 

REN  ...  CLINIC  CODE  WHEN  SINGLE  BUBBLED  ... 

IF  MIOSITEXTS.SO.I)*"  "  THEN  102 
X°VAL(MI0S(TEXTS,30,1)} 

CL1.C00$>CLIBUB$(X) 

REM  •••  VISIT  DATE 

102  CM$=MI0$<0ATES,1,2)  'CURRENT  MONTH 

YRS=HIDS(0ATES,9,2)  'CURRENT  YEAR 

X$=MIDS(TEXTS,31,4)  'MONTH  AND  DAY  FROM  FORM 

IF  LEFT$(X$,2)«CM$  THEN  104  'OX,  USE  THIS  YEAR 

YRt=RIGHT$(STR$<VAL<YRt)-1),2)  'USE  LAST  YEAR 

104  VOATES  =  YRS  ♦  X$ 

'EDIT  VISIT  DATE 

CK.5000$=VOATE$ 

GOSUB  5000  'DATE  CHECK 

CK.5010$=VOATES 

GOSUB  5010  'NUMERIC  STRING  CHECK 

IF  RT.5000  =  0  ANO  RT.5010  =  0  THEN  GOTO  106 
N.ERR=N.ERR4l 

ED.MSG$(N.ERR)*"TOOAYS  DATE  "  ♦  0ATEERRS(RT.5000) 

REM  **•  PROVIDER  1  ID  (PREFIX  ♦  MUM) 

106  PROVI.PFXS  =  MIDS(TEXT$,35,1) 

PROVI.NUMS  *  MID$(TEXTt,36,4) 

PR1.C00S=PR0V1.PFX$  ♦  PROVI.NUMS 

SSN. OFFSET  =  40 
FMP. OFFSET  =  49 
RSI .OFFSET  =  51 
RPF .OFFSET  =  53 
REF. OFFSET  =  54 
TIM. OFFSET  =  57 
UPR. OFFSET  =  58 


PACP820 

EKG  (00 AA)  FORM 


Offset 

Oats 

Source  Line 

0619 

1214 

PRC. 

OFFSET  «  63 

0620 

1216 

SPE. 

OFFSET  »  81 

0627 

1218 

TOT. OFFSET  »  50 

062E 

121A 

POINTER  »  0 

0635 

121C 

0635 

121C 

0635 

121C 

REM 

REPEAT  THE  FOLLOWING  CODE  4  TIMES 

0635 

121C 

FOR  1910°  1  TO  4 

063C 

121C 

063C 

121C 

REM 

•••  SSN  AND  FMP  ••• 

063C 

121C 

110 

SSN.COO$(I910)°MID$(TEXTS,SSN.OFFSET>POINTER,9) 

065  F 

121E 

FMP.COOS(I910)°MIOS(TEXT$,FHP.OFFSET«POtNTER.2) 

0682 

121E 

IF  SSN.COOS(1910)+FMP.CaOS(I910)>STRlNGS(11,*  THEN  130 

06AF 

121E 

06AF 

121E 

REM 

REFERRAL  CODE  **• 

06AF 

121E 

112 

XS°HIDS(TEXT$,RS(.OFFSET«POINTER,2)  'SINGLE  BUBBLE  CODE 

06C6 

121E 

IF  XS="  "  THEN  114 

0604 

121E 

X°VAL(Xt) 

06E1 

121E 

REF.COO$(I910)°REFCOO$(X)  'USE  TABLE 

06FE 

121E 

GOTO  116 

0702 

121E 

0702 

121E 

114 

X=VAL(MIOS(TEXT$,RPF.OFFSET+POINTER,1)) 

0710 

121E 

REF,COO$<191O)«CLINIC2.PFX$<X)*Mt0$<TEXTS,REF.OFFSET+POINTER, 

0751 

121E 

0751 

121E 

REM 

TIME  SPENT  ••• 

0751 

121E 

116 

X=VAL(MIOS<TEXTS,TIM.OFFSET*POINTER,1)) 

076C 

121E 

PR1.TINS(I910}°PROVIOER.TIMES(X} 

0789 

121E 

IF  PR1.TIM$(1910)<>“000"  THEN  118 

07A1 

121E 

n7A1 

121E 

N.ERR=N.ERR+1 

07A9 

121E 

ED.MSG$(M.ERR)="NO  TIME  CMEO  FOR  PART  "♦STR$(I910) 

07C6 

121E 

07C6 

121E 

REM 

•••  ADDITIONAL  PROCEDURE 

07C6 

121E 

118 

ADDP$=M IDSITEXTS, UPR .OF  FSET+POI HTER ,5 ) 

07DO 

1222 

0700 

1222 

REM 

PROCEDURE  COOES  FOR  PROV  1  ••• 

0700 

1222 

120 

X$  »  MIOS<TEXTS,PRC.OFFSET*POINTER,N.PROC) 

07F5 

1222 

GOSU8  6000  'DECODE  THE  XS  STRING 

07FA 

1222 

IF  TOT  °  0  THEN  GOTO  122 

0909 

1224 

FOR  1910. A=  1  TO  TOT 

0816 

1226 

PTR=VAL(HOL0S(I910.A)) 

082C 

122A 

GROUP1${1910,I910.A)=PROCED$(PTR) 

004E 

122A 

NEXT  1910. A 

085  F 

122A 

085  F 

122A 

REM 

...  ADO  UNLISTED  CODE  IF  THERE  TO  PROV  1  ... 

085  F 

122A 

122 

IF  A00P$="  "  THEM  124 

0860 

122A 

TOT=TOT+1 

0875 

122A 

GROUP 1 $( I 91 0 , TOT ) =AD0P$ 

088E 

122A 

rasE 

122A 

124 

TOT.PROC(I910)=TOT 

0890 

122A 

IF  TOT>0  THEN  126 

08a8 

122A 

0£.A8 

122A 

N.ERR=N.ERR+1 

ohbo 

122A 

ED.MSGt(N.F3R)  =  '‘N0  PROCEDURE  COOED  FOR  PART  "♦STR$(I910) 

FACE  8 
04-29-87 
08:18:35 

IBM  Personal  Conputer  BASK'  CnapUer  VI. 00 


RACPB20 

EKG  (OOAA)  FORM 


Offset 

08CO 
08C0 
08CD 
08E4 
08E9 
OfiFD 
08FD 
0908 
091A 
091B 
091B 
091B 
0918 
091 B 
092A 
093C 
0949 
0955 
096B 
097C 
0988 
098F 
0994 
0998 
0998 
0999 
0999 
0999 
0999 
0999 
0999 
0999 
0999 
0999 
0999 
0999 
0999 
0999 
0999 
0999 
0999 
0999 
099E 
099E 
099E 
099E 
099E 
099E 
099E 
09A5 
0905 
09F4 
0A09 
0A18 


PAGE  9 
04  29-87 
08:18:?s 

Data  Source  Line  IBM  Personal  Coinputer  BASIC  Conipiler  “KOO 


122A 

122A 

122A 

122E 

122E 

1232 

1232 

1232 

1232 

1232 

1232 

1232 

1232 

1232 

1232 

1232 

1234 

1238 

1238 

1238 

1238 

1238 

1238 

1238 

1238 

1238 

1238 

1238 

1238 

1238 

1238 

1238 

1238 

1238 

1238 

1238 

1238 

1238 

1238 

1238 

1238 

1238 

1238 

1238 

1238 

1238 

1238 

1238 

1238 

1238 

1240 

1244 

1244 

1244 


REM  •••  SPECIFIC  PRE ASSIGNED  CL  COOES 

126  IHP.STOS=  MID$(TEXTS.SPE.OFFSET+POINTER,9) 

COSUB  5700  'CONVERT  ARRAY 

SPE . coosc I 91 0 }=BUF . sros 

130  POINTER  •  POINTER  ♦  TOT. OFFSET 
NEXT  1910 
199  REN 

REM . END  OF  MODULE  RACM820.M01 . 


IF  N.ERR  •  0  THEN  GOTO  997 
LPRINT  "LITHO  «  ";LITHO$;"  ...  ERRORS" 

FOR  1997  »  1  TO  N.ERR 
LPRINT  USING  "«#«  ";I997; 

LPRINT  «==>  ";ED.MSG$<I997) 

NEXT  1997 

LN. COUNT  >  LN. COUNT  *  N.ERR  +  1 
CNTRLOPT  »  6 

COSUB  9010  'REJECT  THE  FORM 

GOTO  998  'BYPASS  THE  DISK  WRITER.... 

997  REM  SINCLUOE:  'RACH820.MO2'  REM  INCLUDE  THE  BASE  ENCOUNTER  FORM  DISK  WRITER 
REM 
REM 
REM 
REM 
REM 
REM 
REN 
REM 
REM 
REM 
REM 
REN 
REM 

REM  BUILD  THE  OUTPUT  RECORD 

GOSUB  270  'BUILD  THE  RECORD  KEY 

REM 

REM  RECORD  TYPE  "1"  -  RECKEY  PLUS  TYPE  1  FIELDS 

REM 

REM  RECOUTS  ="8201"*RECKEY$  'TRANSACTION  IDENTIFIER 
FOR  1910  =  1  TO  4 

RECOUTS  =  "8201"  ♦  RECKEYS  ♦  RIGHr$(STR$(I910),1)  ♦  RICHTSfL ITHOS, 7) 

PTIOi*  SSN.C0Ot(I910)  ♦  FMP.C005(I910) 

IF  PTID$»  STRINGSdl,"  ")  THEN  210  'NO  MORE  TO  DO 

MIDS(RECOUTS, 20, 11 )=PTI0S 

TYPEIS  ="821"+PR1.TIMt{I910)+STRIMG$(10."  ")»REF .COOS< 1910) 


AMBULATORY  CARE  INFORMATION  SYSTEM  14  MAR  87 

D  R  BOLLING 

HOOULE  NAME  :  RACN820.HO2 

SCANNER  PROGRAM  #  820-  EKG  (DDAA)  FORM 

PURPOSE  ;  CREATE  AND  WRITE  THE  DISK 

RECORD  FOR  INPUT  TO  FOCUS 

PROGRAM  ADDS  PREFIX  TO  LITHO  FOR  EACH  PATIENT 


RESERVED  LINE  NUMBERS  200-299 


RACPKO  page  10 

EKG  (DDAA)  FORM  04'29-87 

08:18:35 

Offttt  Data  Source  Line  tBM  Personal  Coinputer  BASIC  Ccnpiter  VI. 00 


0A4C  1248  RECOUTS  ^recOUTS  «  TYPEIS  *  STRIHGS<16,*  ■•) 

0A67  1248  GOSUB  280 

0A6C  1248  PRINT  «1, RECOUTS 

0A77  1248  NEXT  1910 

0A89  1248 

0A89  1248  210  REH  ...  NO  MORE  ON  THIS  FORM  ... 

0A8A  1248 

0A8A  1248  REH 

0A8A  1248  REN 

0A8A  1248  REM 

0A8A  1248  REH 


0A8A 

1248 

0A8A 

1248 

FOR  1910  «  1  TO  4 

0A91 

1248 

FOR  I910.A  >  1  TO  TOT. PROC( 1910) 

OAAS 

124  A 

RECOUTS  •  •*8202«  «  RECKEYS  ♦  R1GHTS(STR$(I910).1)  +  RIGHTS(LITHOS, 7) 

OAOS 

124  A 

PTI0S>  SSN.COOS(1910)  *  FHP.COOS(I910) 

0AF4 

124  A 

IF  PTtDS«  STRINGSdl,"  ■)  THEN  250  'NO  MORE  TO  DO 

0B09 

124A 

M1DS(RECOUTS,20,11)>PTIOS 

0B18 

124  A 

RECOUTS  =RECOUT$  ♦  "821"  ♦  GR0UP1$(I910, I910.A) 

0B3C 

124  A 

GOSUB  280 

0B41 

124  A 

PRINT  #1, RECOUTS 

0B4C 

124A 

NEXT  I910.A 

0880 

124A 

250 

NEXT  1910 

0872 

124A 

OB  72 

124A 

REH 

•««««*«**«««****«««*««««««****««««*«*M**«**«t|«*«*«i*«i»**«***«****** 

OB  72 

124A 

REN 

RECORD  TYPE  “3"  -  RECXEY  PLUS  SPEC  PRE  CLINIC  COOES 

0872 

124  A 

REH 

0872 

124A 

0B72 

124A 

FOR  1910  »  1  TO  4 

0879 

124  A 

IF  LEN(SPE.COO$(I910))=0  THEN  260 

0B8F 

124A 

RPOIHT  =  1 

0B96 

124C 

0896 

124C 

252 

REC003S=RIGHT$(MID$(SPE.COO$(I910),RPOIMT,2),1) 

0888 

1250 

IF  REC003S="  "  THEN  254 

0BC6 

1250 

RECOUTS  »  "8203"  ♦  RECKEYS  ♦  RIGHTS(STR$<I910),1)  ♦  RIGHTS(LITHO$,7) 

08F6 

1250 

PT10$=  SSH.C0O$(1910)  ♦  FHP.C00S(I910) 

0C15 

1250 

IF  PTI0$=  STRINGSdl,"  ")  THEN  260  'NO  MORE  TO  DO 

UC2A 

1250 

H I0S<  RECOUTS , 20 , 1 1 )=PT 1 0$ 

0C39 

1250 

RECOUTS  =REC0UTS  ♦  "82"  ♦  REC003S 

0C4C 

1250 

GOSUB  280 

CC51 

1250 

PRINT  *1, RECOUTS 

OCSC 

1250 

0C5C 

1250 

254 

RPOINT  »  RPOINT  +  2 

0C65 

1250 

IF  RPOINT  <  LEN(SPE.COO$(I910))  THEN  252 

0C7D 

1250 

0C7D 

1250 

260 

NEXT  1910 

0C8F 

1250 

.C8F 

1250 

REM  ENO  OF  TYPE  3  RECORDS 

0C3F 

1250 

orsF 

1250 

GOTO 

299 

0C93 

1250 

0C93 

1250 

REH 

OC-TJ 

0C93 

1250 

1250 

REM 

REM 

**♦*  SUBROUTINE  270  -  BUILD  THE  RECORD  KEY  ***' 

****  RECORD  TYPE  “2“  -  RECXEY  PLUS  PROCEDURE  CODE 


************************ 


RECOUTS  °'<8202"«RECICETS  'TRANSACTION  IDENTIFIER 


RACP820 

EKG  (OOAA)  FORK 

Offset  Data  Source  Line 

0C93  1250  270  RECKEY$=«" 

0C9C  1250 

0C9C  1250  REM  CLINIC  ID  (PREFIX  ♦  CCOE) 

0C9C  1250  RECKEY$>  CL 1. COOS 

0CA5  1250 

0CA5  1250  REM  VISIT  DATE  **• 

0CA5  1250  RECXEY$>RECKEYS+  VDATES 

0CB1  1250 

0C81  1250  REM  ***  PROVIDER  ID  (PREFIX  ♦  NUM)  ••• 

0CB1  1250  RECXEYS  >  RECKEYS  *  PROVl.PFXS  «  PROV1.HUMS 

0CC4  1250 

0CC4  1250  REM  **•  PATIENT  ID  (SSN+FMP) 

0CC4  1250  RECKEYS  «  RECKEYS  ♦  STRINGSdl,**  ■) 

OC06  1250 

0CD6  1250  REM  •••  LITMO  CODE 

OC06  1250  REM  DO  LITHO  IN  LOOP  ABOVE 

OC06  1250  REM  RECKEYS  ^  RECKEYS  *  LITHOS 

0C06  1250 

0CO6  1250  RETURN 

OC09  1250 

0CD9  1250  REM 

OC09  1250  REM  SUBROUTINE  280  •  PAD  THE  RECORD  TO  MAXLENGTH 

0C09  1 250  REM  •**•«««*«*«*•••««•««***«•*•••••**•«**«*•«•«••*«•*#***«**•**••#«•••• 

OC09  1250  280  PAO^UUXLENGTH  •  LEN(RECOUTS)  'FIND  OUT  HOW  SHORT  THE  RECORD  IS 

0CE7  1252  RECOUTS  >  RECOUTS  *  STRINCS(PAO,PAOS)  'PAD  THE  RECORD  WITH  FILL  CHAR 

OCFA  1252  RETURN 

OCFO  1252 

OCFD  1252 

OCFD  1252  299  REM 

OCFE  1252 

OCFE  1252  REN  . END  OF  MODULE  RXXM820,M02 . 

OCFE  1252 

OCFE  1252  998  REM  CONTINUE 

OCFF  1252 

OCFF  1252  999  REAOTTPE  »  2 

0006  1252  IF  LN. COUNT  >  48  THEN  GOSUB  7100  'PRINTER  HEADING 

0016  1252  GOTO  10 

0D1A  1252 

0O1A  1252  REM  END  OF  SCAN/OECOOE/WRITE  LOOP  «r===s==========r=====s=r===rr=»=..=== 

0O1A  1252 

0D1A  1252  1000  REN  SINCLUOE:  'RACS 1000. SUB'  INCLUDE  THE  VERIFY  LOGON  SUB 

0O1B  1252  REM 

0D1B  1252  REN  *  NAME:  RACS1000  LOGON  VERIFICATION  SUBROUTINE  * 

ODIB  1252  REM  •  Date:  28  Feb  84  PATIENT  REGISTRATION  PROGRAM  • 

0018  1252  REM  ••*•*•••**«••••*••*•*••••••••••••••••••••••••••••••••**••••*••••••*•* 

0O1B  1252  REM  PATIENT  OMR  INPUT  PROGRAM  * 

0O1B  US2  REM  * 

0O1B  1252  REM  This  program  verifies  user  is  logged  on  properly.  If  there  is  no  • 

0O1B  1252  REM  valid  user  logged  on  at  the  time  of  execution,  this  subroutine  will* 

0018  1252  REM  chain  to  the  logon  program  RACP05,  otherwise  a  return  is  issued.  • 

0018  1252  REM 

ODIB  1252  REM  RESERVED  LINE  NUMBERS  ARE  1001  THRU  1010 

001B  1252  REM 

001B  IZ"::  10C1  OPEN  1  ."RACLOG.OAT" 
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00 2D 

1252 

IF  E0F(1> 

THEN  1002 

'MAKE  THEM  LOG  ON  FIRST 

0O3B 

1252 

INPUT  «1,USERS(1},DTS,TNS,PI0S 

ODSC 

125E 

IF  USERS(I)  *  •"  THEM  1002 

•HAKE  THEM  LOG  ON  FIRST 

0O6A 

125E 

IF  USERSd)  »  ••**•••«  then  1002  ‘HAICE  THEM  LOG  ON  FIRST 

0078 

125E 

CLOSE  1 

0O7F 

125E 

SCREEN  0,1 

.0,0 

0095 

125E 

COLOR  FORE, BACK, BORO 

OOAB 

125E 

CLS 

OOAF 

125E 

RETURN 

0OB2 

125E 

0DB2 

125E 

1002  CLOSE 

0066 

12SE 

CHAIN  "RACP05" 

ODBC 

125E 

i>xxs3>=3s>siEN0  of  logon  verify  subroutine  1000*=»»=»==»=»=«=»««=««=»**==» 

OOBO 

125E 

OOBD 

12SE 

2000 

REH  SINCLUDE:  •RACS2000.SUB* 

INCLUDE  THE  REPLY/DELAY  SUB 

OOBE 

12SE 

REN 

*«*«*««***««*«***«•*««««**«•««**««*«*«♦••*«*«*•«*«*«**•••*•*««*«♦•« 

008E 

125E 

REN 

**** 

AMBULATORY  CARE  DATA 

BASE  13  APR  85 

**•* 

OOBE 

12SE 

REM 

*«*« 

SKIP  COLE 

OOBE 

125E 

REM 

**** 

SUBROUTINE  NAME 

RACS2000.SUB 

***« 

OOBE 

125E 

REM 

«*«« 

SCANNER  PROGRAM  « 

ALL 

•**« 

OOBE 

125E 

REM 

FUNCTION 

THIS  SUBROUTINE  MODULE 

**** 

OOBE 

125E 

REM 

SERVERS  AS  A  WAIT  AND  REPLY 

OOBE 

125E 

REM 

*««* 

ENTRY  MODULE 

OOBE 

125E 

REM 

**«* 

INPUT 

SINGLE  KEYBOARD  ENTRY 

OOBE 

125E 

REM 

*««« 

OOBE 

125E 

REM 

OUTPUT 

KEYBOARD  ENTRY  •  UPPER  CASE 

*«•* 

OOBE 

125E 

REM 

**** 

OOBE 

125E 

REM 

RESERVED  LINE 

OOBE 

125E 

REN 

««** 

NUMBERS 

2001-2010 

***• 

OOBE 

125E 

REM 

*'**'*«**'8 

»*«***«•*«•***'*•*«*•*♦«♦*«**♦•*•««* 

OOBE 

125E 

2001 

REM  REPLY  FUNCTION 

OOBF 

125E 

2002 

REPLY$=INKEY$  :  If  REPLY$=""  THEN  2002 

0003 

1262 

REPLY=ASC(REPLY$) 

0000 

1264 

IF  REPLY 

>  90  THEN  REPLYS=CHR$(REPLY  XOR  32)  'CONVERT  TO  CAPS 

OOFS 

1264 

IF  REPLYS  <  "A"  OR  REPLYS  >  "Z"  THEN  REPLY$="?" 

0E24 

1264 

RETURN 

0E27 

1264 

0E27 

1264 

5000 

REN  SINCLUDE:  ’RACS5000.SUB' 

INCLUDE  THE  DATE  EDITOR  SUB 

0E2S 

1264 

REM 

0E28 

1264 

REM 

**** 

AMBULATORY  CARE  DATA 

BASE  13  APR  85 

*«** 

0E28 

1264 

REM 

SKIP  COLE 

*««* 

0E28 

1264 

REM 

***« 

SUBROUTINE  NAME 

RXXS5000.SUB 

**♦* 

0E28 

1264 

REM 

SCANNER  PROGRAM  # 

ALL 

**** 

CE28 

1264 

REN 

«*•« 

FUNCTION 

THIS  SUBROUTINE  MODULE 

UE2a 

1264 

REM 

*«** 

PERFORMS  A  DATE  EDIT 

«*«* 

0E28 

1264 

REM 

**** 

**** 

0F28 

1264 

REM 

**•* 

INPUT 

DATE  TO  BE  CHECKED  MUST  BE 

**** 

0E28 

1264 

REM 

**** 

IN  THE  VARIABLE  NAMED 

0E28 

1264 

REM 

•CK.SOOOS' 

**** 

0E28 

1264 

REM 

**** 

IN  THE  FORMAT  "TYMMOD" 

*«•* 

0E28 

1264 

REH 

«*«* 

**** 

0E28 

1264 

REM 

OUTPUT 

'RT.5000'  IS  THE  RETURN  CODE 

**«* 

CE28 

1264 

REM 

**•*’ 

VARIABLE.  IF  THIS  VARIABLE 

**«« 

Of  23 

1264 

REM 

***  A 

CONTAINS  ANY  NUMBER  OTHER 

*•** 

RACPSaO 
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0E28 

1264 

REM 

THAN  0,  AN  ERROR  WAS  FOUND 

0E28 

1264 

REM 

IN  THE  DATE. 

**** 

0E28 

1264 

REM 

**** 

0E28 

1264 

REM 

RESERVED  LINE 

0E28 

1264 

REM 

NUMBERS  :  5001-5009 

*«** 

0E28 

1264 

REM 

0E28 

1264 

RT 

5000  *  0 

0E2F 

1264 

CKfEAR  *  VAL(LEFT»<CIC.5000$,2))  ‘YEAR  NUMERIC  VALUE 

0E42 

1266 

CXMONTH  «  VAL(MIDS<CK.5000S,3,2)>  'MONTH  NUMERIC  VALUE 

K58 

1268 

CKDAY  >  VAL(RIGHTS(CK. 50008,2))  'DAY  NUMERIC  VALUE 

0E6B 

126A 

0E68 

126A 

IF  OCMOHTK  <  1  THEN  RT.SOOOal  :  GOTO  5009 

0E81 

126A 

IF  CKMONTH  >  12  THEN  RT. 5000*1  :  GOTO  5009 

0E97 

126A 

IF  CKDAY  <  1  THEN  RT. 5000*2  :  GOTO  5009 

OEAO 

126A 

IF  CKDAY  >  31  THEN  RT. 5000*2  :  GOTO  5009 

0EC3 

126A 

0EC3 

126A 

REM 

LEAP  YEAR  CHECK 

0EC3 

126A 

M0LENGTH(2)  «  28 

OECA 

126A 

IF  CKMONTHo  2  THEM  GOTO  5005  'MUST  BE  FEBRUARY 

0E09 

126A 

IF  (CKYEAR  MOO  4)  <>  0  THEN  GOTO  5005  'MUST  BE  A  LEAP  YEAR 

OEEE 

126A 

MOLENGTH(2)  *  29 

OEFS 

126A 

OEFS 

126A 

5005 

IF  CKDAY  >  MOLEHGTHCCKMONTH)  THEN  RT. 5000*3  :  GOTO  5009 

0F14 

126A 

OFU 

126A 

5009 

RETURN 

0F17 

126A 

0F17 

126A 

0F17 

126A 

0F17 

126A 

5010 

REM  SINCLUOE:  'RACS5010.SUB'  INCLUDE  THE  NUMERIC  STRING  EDITOR 

0F18 

126A 

REM 

0F18 

126A 

REM 

AMBULATORY  CARE  DATA  BASE  1  MAT  85 

0F18 

126A 

REM 

SKIP  COLE 

0F18 

126A 

REM 

subroutine  name  ;  RXXS5010.SUB 

**•* 

0F18 

126A 

REM 

***« 

SCANNER  PROGRAM  «  :  ALL 

0F18 

126A 

REM 

FUNCTION  :  THIS  SUBROUTINE  MODULE 

**** 

0F18 

126A 

REM 

PERFORMS  A  NIMERIC  STRING 

0F18 

126A 

REM 

**«* 

EDIT. 

0F18 

126A 

REM 

OF  18 

126A 

REN 

***• 

INPUT  ;  STRING  TO  BE  EDITED  IS  IN 

•«** 

0F18 

126A 

REM 

*•*« 

THE  VARIABLE  NAMED 

•  *«* 

0F18 

126A 

REM 

•*«* 

'CK. 50108' 

**** 

0F18 

126A 

REN 

0F18 

126A 

REM 

OUTPUT  :  'RT.5010'  IS  THE  RETURN  CODE 

**** 

0F18 

126A 

REM 

**«« 

VARIABLE.  IF  THIS  VARIABLE 

0F18 

126A 

REM 

**** 

CONTAINS  ANY  NUMBER  OTHER 

0F18 

126A 

REM 

**** 

THAN  0,  AN  ERROR  WAS  FOUND 

**** 

0F18 

126A 

REN 

**•* 

IN  THE  STRING. 

0F18 

126A 

REM 

**** 

**•« 

0F18 

126A 

REM 

**** 

RESERVED  LINE 

0F18 

126A 

REM 

•*** 

NUMBERS  :  5011-5019 

***« 

0F18 

126A 

REM 

»•••* 

0F18 

126A 

RT 

5010  *  0 

0f1f 

126A 

0F1F 

126A 

FOR  15010  =  1  TO  LEN(CK. 50108) 

i 
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OfZF 

126C 

J5010«  ASC(MI0S(CK.5010S 

15010,1)) 

0F43 

1270 

IF 

J5010  <  48  OR  J5010  > 

57  THEN  RT.5010  =  RI.5010  ♦  1 

0F6B 

1270 

NEXT  15010 

0F7C 

1270 

0F7C 

0F7F 

1270 

1270 

RETURN 

0F7F 

1270 

5500 

REM  INCLUDE:  ‘RACS5500.SUB> 

INCLUDE  THE  OUTPATIENT  UCA  CHECK 

SUB 

OFSO 

1270 

5700 

REN  $ INCLUDE:  'RACS5700.SUB‘ 

INCLUDE  THE  ARRAY  CONVERTER  SUB 

0F81 

1270 

REM 

»******•**••«*•*•*«#««*«*♦««***«** 

0F81 

1270 

REM 

AMBULATORY  CARE  DATA 

BASE  29  JUL  85 

0F81 

1270 

REM 

**♦* 

D  R  BOLLING 

*«•* 

0F81 

1270 

REM 

*#■*« 

SUBROUTINE  NAME 

RXXSS700.SUB 

**«• 

0F81 

1270 

REM 

«•** 

SCANNER  PROGRAM  « 

ALL 

0F81 

1270 

REM 

FUNCTION 

THIS  SUBROUTINE  MODULE 

**«• 

0F81 

1270 

REM 

CONVERTS  A  BINARY  ARRAY  INTO 

**#* 

0FB1 

1270 

REM 

***« 

TUO  CHAR  CODES. 

**•* 

0F81 

1270 

REM 

**«* 

0F81 

1270 

REM 

INPUT 

INP.STOS  AS  STRING 

**** 

0F81 

1270 

REM 

«•*« 

0F81 

1270 

REM 

•  «*« 

**** 

OFSI 

1270 

REM 

**«* 

OUTPUT  :  BUF.STOS  AS  STRING. 

*«*• 

OFS! 

1270 

REM 

*«*« 

**** 

0F81 

1270 

REM 

**•* 

0F81 

1270 

REM 

RESERVED  LINE 

0Fai 

1270 

REM 

*«*• 

NUMBERS 

5710-5730 

•  *** 

0F81 

1270 

REM 

0F81 

1270 

0F81 

1270 

BUF.STO*=‘"' 

0F8A 

1270 

N.STO= 

1 

3F91 

1272 

5710 

X.STO= 

INSTR<N.STO, INP.ST0$,"1") 

0FA3 

1274 

IF  X.STO=0  THEN  GOTO  5720  'THATS  ALL 

0FB2 

1274 

N.STO 

=  X.STO  ♦  1  'NEXT  STARTING  POINT 

0F8A 

1274 

X.STO 

=  X.STO  +  100  'PAD  WITH  LEADING  ZERO 

0FC4 

1274 

BUF.STOS  »  BUF.STOt  ♦  RIGHT$(STR$<X,ST0).2) 

OfDA 

1274 

IF  N.STO  <=  LEN<INf>.STO»)  THEM  GOTO  5710 

OfED 

1274 

OFEO 

OFFO 

OFFO 

1274 

1274 

1274 

5720 

RETURN 

Htn 

t'FO 

1274 

OFFO 

1274 

6000 

REM  SINCLUOE:  'RACS6000.SUB' 

INCLUDE  THE  INSTRING  DECODE  ROUTINE 

0FF1 

1274 

REM 

OFFl 

1274 

REM 

AMBULATORY  CARE  DATA 

BASE  13  APR  85 

*«** 

0FF1 

1274 

REM 

***♦ 

SKIP  COLE 

**•# 

OFFl 

1274 

REM 

**** 

SUBROUTINE  NAME 

RXXS6000.SUB 

*•*« 

3FF1 

1274 

REM 

**«* 

SCANNER  PROGRAM  # 

ALL 

**«* 

OFFl 

1274 

REM 

***• 

FUNCTION 

THIS  SUBROUTINE  MODULE 

**** 

OFFl 

1274 

REM 

***• 

PERFORMS  INSTRING  SEARCH 

*«** 

OFFl 

1274 

REM 

*•«* 

F'-FI 

1274 

REM 

**«* 

iNPUT 

STRING  TO  BE  SEARCHED  MUST 

**** 

OFFl 

1274 

REM 

*■»*» 

BE  IN  THE  VARIABLE  NAMED  : 

OFFl 

1274 

REM 

**** 

'XS' 

OFFl 

1274 

REM 

«*** 

OFM 

1274 

REM 

*«*« 

OUTPUT 

•TOT*  =  TOTAL  NUMBER  OF 

ltACP820 
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0FF1 

1274 

REM 

•«** 

NITS  IN  THE  DESTRING 

***« 

0FF1 

1274 

REM 

■HOLOSO'  IS  THE  ARRAY 

*«*« 

0FF1 

1274 

REM 

*««« 

CONTAINING  THE  NUMERIC 

•■*** 

0FF1 

1274 

REM 

VALUE  OF  THE  HIT  POSITIONS 

*«** 

0FF1 

1274 

REN 

*•** 

«•** 

0FF1 

1274 

REN 

•*««*****•****«*««•**«««****«*«******«**••**♦*««**•***•*««**«***«*« 

0FF1 

1274 

REN 

***• 

RESERVED  LINE 

•*** 

0FF1 

1274 

REN 

NUMBERS  : 

6001-6009 

**** 

OFFI 

1274 

REM 

R***** 

0FF1 

1274 

6001 

PTR  «  INSTR<X$,“1“) 

OFFF 

1274 

TOT  «  0 

1006 

1274 

WHILE  PTR  >  0 

1011 

1274 

TOT=TOT+1 

1019 

1274 

HOLDS(TOT)  >  RIGHT$(STRS(PTR),2) 

103B 

1274 

PTR=PTR+1 

1043 

1274 

PTR  »  INSTR(PTR,XS,"1 

") 

1055 

1274 

UENO 

1059 

1274 

RETURN 

105C 

105C 

1274 

105C 

1274 

105C 

1274 

105C 

1274 

7000 

REM  SINCLUOE:  'RACSTOOO.SUB' 

INCLUDE  THE  SCREEN  HEADER  SUB 

1050 

1274 

REM 

»****« 

1050 

1274 

REM 

•««« 

AMBULATORY  CARE  DATA  BASE  13  APR  85 

**«• 

1050 

1274 

REM 

•  ««« 

SXIP  COLE 

*«•* 

1050 

1274 

REN 

SUBROUTINE  NAME 

RACSTOOO.SUB 

•*** 

1050 

1274 

REM 

•**« 

SCANNER  PROGRAM  » 

ALL 

1050 

1274 

REM 

**** 

FUNCTION 

THIS  SUBROUTINE  MODULE 

•**• 

1050 

1274 

REM 

•*** 

PRINTS  THE  STANDARD  SCREEN 

**•* 

1050 

1274 

REN 

HEADING. 

**** 

1050 

1274 

REM 

**«« 

INPUT 

COMMON  VARIABLE  USERS(2) 

*•** 

1050 

1274 

REM 

***« 

SYSTEM  DATE 

***• 

1050 

1274 

REM 

«*** 

*«■• 

1050 

1274 

REN 

OUTPUT 

SCREEN  HEADING 

*«*• 

1050 

1274 

REN 

•«** 

1050 

1274 

REM 

•*#* 

RESERVED  LINE 

*••* 

1050 

1274 

REM 

NUMBERS 

7001-7010 

**** 

1050 

1274 

REM 

***** 

1050 

1274 

1050 

1274 

7001 

LOCATE 

1.1 

1067 

1274 

PRINT 

■U.S.  ARMY  AMBULATORY  CARE  INFORMATION  SYSTEM" 

106F 

1274 

LOCATE 

1,65 

107C 

1274 

PRINT 

DATES; 

1084 

1274 

LOCATE 

2,1 

1091 

1274 

PRINT 

■USER  :  ";USERS(1) 

109E 

1274 

RETURN 

10A1 

1274 

7100 

REM  SINCLUOE:  <RACS7100.SUB' 

INCLUDE  THE  PRINTER  HEADER  SUB 

10A2 

1274 

REM 

10A2 

1274 

REM 

**** 

AMBULATORY  CARE  DATA 

BASE  13  APR  85 

•  •** 

10A2 

1274 

REM 

**•• 

SXIP  COLE 

**** 

10A2 

1274 

REM 

**** 

SUBROUTINE  NAME 

RXXS7100.SU8 

•  •** 

10A2 

1274 

REM 

***• 

SCANNER  PROGRAM  N 

ALL 

•*#* 

10A2 

1274 

REM 

**•* 

FUNCTION 

THIS  SUBROUTINE  MODULE 

»«** 

RACP820 
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10A2 

1274 

REM 

PRINTS  THE  STANDARD  HEADING 

***« 

10A2 

1274 

REM 

•*** 

OH  THE  PRINTER. 

10A2 

1274 

REM 

INPUT 

:  DATE.PAGE.PGMIDS.PGMTITLS 

**** 

10A2 

1274 

REM 

10A2 

1274 

REM 

OUTPUT 

:  PRINTER  HEADING,  LN. COUNT 

**** 

1CA2 

1274 

REM 

«**« 

•**« 

10A2 

1274 

REM 

«*** 

RESERVED  LINE 

**** 

10A2 

1274 

REM 

NUMBERS 

:  7101-7110 

**** 

10A2 

1274 

REM 

»*«**««***«*«***««********•«•***«•********«•«*••**•**•*•««*•«* 

10A2 

1274 

10A2 

1274 

7101 

IF  PAGE  >  0  THEN  LPRINT  CNR$(12}; 

10B8 

1274 

LPRINT 

"ARMY  AMBULATORY  OARE 

INFORMATION  SYSTEM _  ";PGMTITLS, 

10C5 

1274 

LPRINT 

TAB(70);DATES 

1008 

1274 

PAGE^PAGErl 

10E0 

1274 

LPRINT 

"PROGRAM  “ ; PGM 1 0$ ; T AB <  70 ) ; "PAGE" ; 

10F0 

1274 

LPRINT 

USING  "###«"; PAGE 

1109 

1274 

LPRINT 

1111 

1274 

LN.e0UNT=3 

1118 

1274 

RETURN 

1118 

1274 

111B 

1274 

8000 

REM  SINOLUDE:  <RAeS8000.SUB' 

INCLUDE  THE  DECODE  SUB  GROUP 

me 

1274 

REM 

*«««*♦«**»**«•*****•**•*•*«••***•« 

me 

1274 

REN 

AMBULATORY  CARE  DATA  BASE  13  APR  85 

me 

1274 

REM 

««•* 

SKIP  COLE 

me 

1274 

REM 

««•* 

SUBROUTINE  NAME 

:  RXXSSOOO.SUB 

me 

1274 

REM 

**** 

SCANNER  PROGRAM  * 

:  ALL 

**• 

me 

1274 

REM 

•  ««« 

FUNCTION 

:  THIS  SUBROUTINE  MODULE 

me 

1274 

REM 

*•«« 

IS  A  GROUPING  THAT  PERFORMS 

«*• 

me 

1274 

REM 

VARIOUS  DECODING  FUNCTIONS 

*«* 

me 

1274 

REM 

**«* 

ON  THE  SCANNER  DATA 

me 

1274 

REM 

•  «** 

me 

1274 

REM 

***• 

8001  -  DECODE  THE 

HEADER  POSITIONS  (POINTER  0-20) 

*•« 

me 

1274 

REM 

8050  -  CHECK  FOR 

ENO  OF  JOB 

**• 

me 

1274 

REM 

*«** 

8100  -  PRINT  THE 

HEADER  DATA  ON  THE  SCREEN 

me 

1274 

REM 

8200  -  DECODE  THE 

RESPONSE  POSITIONS  (POINTER  21-.. 

me 

1274 

REM 

(RETURNED 

IN  TEXTS  STRING  VARIABLE) 

*** 

me 

1274 

REH 

*««• 

*•* 

me 

1274 

REM 

**** 

INPUT 

:  SHEET  RECORD,  RECORD  LENGTH 

*** 

me 

1274 

REM 

*** 

me 

1274 

REM 

*«** 

OUTPUT 

;  'TEXTS'  TRIHG  VARIABLE 

*«* 

me 

1274 

REH 

*** 

me 

1274 

REH 

RESERVED  LINE 

**• 

me 

1274 

REM 

«*** 

NUMBERS 

:  8001-8500 

me 

1274 

REM 

***** 

.lie 

1274 

me 

1274 

•OECOOE  THE  HEADER  ONLY 

me 

1274 

8001 

POINTER  =  0 

1123 

1274 

RECORDPTR  =  VARPTR<SHEETREO<0)) 

112A 

1276 

FOR  J8000  =  1  TO  21 

1131 

1276 

8002 

TEXT$=  TEXTS*CHR$(PEEK(RECOROPTR  ♦  POINTER)) 

114F 

1276 

POINTER=POINTER*1 

1157 

1276 

NEXT  J8000 

1166 

1278 

PROGRAMt=  LEFTt(TEXTS,3) 

1175 

t27C 

BATC)'t=  HIDt(TEXT$,4,3) 

RACP820 

EKG  (DDAA)  FORH 
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Offset 

Oata 

Source  Line 

1187 

1280 

SERIALS*  M10${TEXTS,7,4) 

1199 

1284 

RUNIOS*  MID$(TEXT$,11,1) 

IIAB 

1288 

FORMS*  MIOS(TEXTS,12,2) 

11BD 

128C 

POCXETS*  M10S(TEXTS,14,1) 

11CF 

1290 

SCANERR1S*H10S(TEXTS, 16,2) 

11E1 

1294 

SCANERR2S=MIDS(TEXTS, 18,2) 

11F3 

1298 

SCARERR3S=M I0S<  TEXTS , 20 , 2 ) 

1205 

129C 

GOTO  8500 

1209 

129C 

1209 

129C 

8050 

REM  CHECK  FOR  END  OF  J08/EM0  OF  BATCH 

120A 

129C 

IF  PROGRAMS  *  PGM  I OS  THEN  GOTO  8500 

121C 

129C 

LPRIHT  STRINCS<80,«»») 

122A 

129C 

LPRINT 

1232 

129C 

LPRINT  “RECORDS  PROCESSED  ...  “;SERIALS 

123F 

129C 

LPRINT  "STARTED  AT  .  ";BTIMES 

124C 

129C 

LPRINT  "ENDED  AT  .  “;TIMES 

1259 

129C 

LPRINT  CHRS<12) 

1264 

129C 

GOTO  30000 

1268 

120C 

1268 

129C 

8070 

REM  CHECK  FOR  SCANNER  ERRORS 

1269 

129C 

IF  POCKETS  »  “  “  GOTO  8500 

127B 

129C 

LPRINT  LITHOS; 

1283 

129C 

LPRINT  "  ...  SCANNER  ERRORS  : 

1288 

129C 

LPRINT  SCANERR1S;"  / 

1298 

129C 

LPRINT  SCANERR2S;"  / 

12A5 

129C 

LPRINT  SCANERR3S 

12A0 

129C 

LN=LN+1 

12B5 

129E 

GOTO  999 

12B9 

129E 

12B9 

129E 

8100 

REM  PRINT  THE  HEADER  VARIABLES  ON  THE  TUBE _ 

12BA 

129E 

LOCATE  5,1: PR  I  NT  "PROGRAM  PROGRAMS; 

1204 

129E 

1204 

129E 

PRINT  “  BATCH  ";BATCH$^r 

12E1 

129E 

PRINT  "  RUN  ";HUNI0S; 

12EE 

129E 

PRINT  "  FORM  FORMS; 

12FB 

129E 

PRINT  "  POCKET  ";POCKETS 

1308 

129E 

GOTO  8500 

130C 

129E 

130C 

129E 

8200 

REM  DECODE  THE  RESPONSE  POSITIONS 

1300 

129E 

POINTER  *  21 

1314 

129E 

RECORDPTR  =  VARPTR(SHEETREC(0) ) 

131B 

129E 

FOR  J8000  *  22  TO  RECOROLENGTH 

1328 

12A0 

8202 

TEXTS  *  TEXTS+CHRS(PEEK( RECORDPTR  ♦  POINTER)) 

1346 

12A0 

POINTER-POINTER+1 

134E 

12A0 

NEXT  J8000 

135F 

12A0 

135F 

12A0 

8500 

RETURN 

1362 

12A0 

1362 

12A0 

1362 

12A0 

1362 

12A0 

9000 

REM  SINCLUOE:  'RACSOOOO.SUB'  INCLUDE  THE  SCANNER  CONTROL  SUB 

1363 

12A0 

REM 

***•  AMBULATORY  CARE  DATA  BASE  13  APR  85 

1363 

12A0 

REM 

****  SKIP  COLE 

(18:13:3S 

IBH  Personal  Computer  BASH:  tonvUer  VI. 00 


RACPSaO 

EKG  (ODAA)  FORM 


Offset 

1363 

1363 

1363 

1363 

1363 

1363 

1363 

1363 

1363 

1363 

1363 

1363 

1363 

1363 

1363 

1363 

1363 

1363 

1363 

1363 

1364 
136B 
1372 

1379 

1380 
1387 
138E 
1395 
1395 
13A1 
13A8 
1389 
13C2 
13DE 
.3E2 
13E2 
13E2 
13E2 
13E2 
13E2 
13E2 
13E2 
13E2 
13E2 
'3E2 
13F.2 
13c2 
13E2 
1353 
.3FF 
UOO 
1409 
1425 


Data 

12A0 

12A0 

12A0 

12A0 

12A0 

12A0 

12A0 

12A0 

12A0 

12A0 

12A0 

12A0 

12A0 

12A0 

12AQ 

12A0 

12AQ 

12AQ 

12A0 

12AQ 

12A0 

12AQ 

lao 

12A0 
12A0 
12A0 
12  AO 
12A0 
12A0 
12A0 
12A2 
12A2 
12A2 
12A2 
12A2 
12A2 
12A2 
12A2 
12A2 
12A2 
12A2 
12A2 
12A2 
12A2 
12A2 
12A2 
12A2 
12A2 
12A2 
12A2 
12A2 
12A2 
12A2 
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REH 

PROGRAM  NAME 

:  RACS9000.SUB 

*»** 

REH 

*«*« 

SCANNER  PROGRAM  * 

:  ALL 

REH 

*«*« 

FUNCTION 

:  THIS  SUBROUTINE  HGOULE 

REM 

CONTROLS  THE  SCANNER  I/O 

REH 

**** 

REM 

INPUT/OUTPUT 

:  REFER  TO  THE  ASYNCHRONOUS 

***• 

REM 

**** 

COMMUNICATIONS  MANUAL  AND  THE 

**** 

REM 

**#« 

PRE-RELEASED  SOFTWARE  GUIDE 

REM 

REM 

**■*« 

**** 

■lAA  A 

REH 

RESERVED  LINE 

•*** 

REM 

*««* 

NUMBERS 

;  9001-9100 

*•** 

REM 

REM 

REM 

SUBROUTINE 

9001  -  PROTOCOL  SETUP  FOR  SCANNER 

REH 

ARGUMENTS: 

PRESET  ...  SEE  BELOW 

REM 

**«*•«***«*•««**«*««««*«*«««•*«*«*«**«%*****««***«•**•«**••«****«*• 

9001 

REM 

PROTOCOL  (0) 

=  9600 

•BAUD  RATE 

PROTOCOL! 1) 

S 

78 

•PARITY  (SEE  PAGE  4-8  OF  MANUAL) 

PR0T0C0L(2) 

s 

8 

•DATA  BITS 

PROTOCOL<3) 

3 

1 

•STOP  BITS 

PROTOCOL(4) 

3 

2 

•RS-232  PORT 

PR0T0C0L(5) 

= 

0 

•WRITE  TIME-OUT 

PROTOCOL{6) 

= 

0 

•READ  TIME-OUT 

ERRSTATS  =  SPACESI60) 

ARGPTR  =  VARPTR(PROTOCOL(0)) 

CALL  SETUP  (ARGPTR, ERRSTATS) 

ERRHSG$=‘"' 

IF  ASC<ERRSTATS)  <> 

64  THEN  ERRMSGS="SETUP  ERROR  "+ERRSTATS 

GOTO  9100 

REM 

REM 

****  SUBROUTINE 

9010  -  CONTROL  OPTIONS  FOR  SCANNER 

REM 

ARGUMENTS: 

CNTRLOPT 

•  «*** 

REM 

CNTRLOPT  = 

1  = 

START  SCANNER 

(SI) 

REH 

***•  CNTRLOPT  = 

2  * 

STOP  SCANNER 

(SO) 

REM 

CNTRLOPT  = 

3  = 

TERMINATE  COMMUNICATIONS  TO  SCANNER  (DC3) 

REH 

•••*  CNTRLOPT  = 

4  « 

CLEAR  TRANSPORT  PATH  (OC2) 

*«*«* 

REM 

****  CNTRLOPT  = 

5  = 

SELECT  PRIMARY 

STACKER  "31" 

***** 

REM 

***•  CNTRLOPT  = 

6  = 

SELECT  SECONDARY  STACKER  "32" 

REM 

CNTRLOPT  = 

7  = 

POSITIVE  RESPONSE/SELECT  SCANNER  (DC1) 

REM 

CNTRLOPT  = 

8  = 

REQUEST  STATUS 

(ESC) 

REM 

****** 

9010  REM 

ERRSTATS  =  SPACES{60) 

CALL  CNTROL  (CNTRLOPT, ERRSTATS) 

ERRHSGS="" 

IF  ASCIERRSTATS)  <>  64  THEN  ERRMSGS=“CONTROL  ERROR  "‘ERRSTATS 
GOTO  9100 
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U29 

12A2 

REM 

U29 

12A2 

REM 

•*.*  SUBROUTINE  9020  -  SCAN  SHEET  CALL 

*«**« 

1429 

12A2 

REM 

***« 

***** 

1429 

12A2 

REM 

••••  ARGUMENTS:  READTYPE 

***** 

1429 

12A2 

REM 

REAOTYPE  *  2  »  REQUEST  NEU  DOCUMENT  FROM  SCANNER 

1429 

12A2 

REM 

READTYPE  =  3  *  RETRANSMIT  CURRENT  DOCUMENT 

***** 

1429 

12A2 

REM 

*-**« 

***** 

1429 

12A2 

REM 

*•**  ARGUMENTS:  RECOROLENGTH 

***** 

1429 

12A2 

REM 

****  NUMERIC  VARIABLE  SET  TO  THE  NUMBER  OF  CHARACTERS  TO  BE 

1429 

12A2 

REM 

TRANSMITTED 

1429 

12A2 

REM 

1429 

12A2 

9020 

REM 

142A 

12A2 

ERRSTATS  >  SPACES(60) 

1436 

12A2 

RECOROPTR  <  VARPTR(SHEETREC(0)) 

1430 

12A2 

CALL  SCAN  (READTYPE, RECOROLENGTH, RECOROPTR.ERRSTATS) 

1456 

12A2 

ERRMSG»="“ 

145  F 

12A2 

IF  MID$(ERRSTAT$,14,3)  «  "415"  THEM  ERRMSGS="ESC" 

1480 

12A2 

GOTO  9100 

1484 

12A2 

1484 

12A2 

REM 

1484 

12A2 

REM 

••••  SUBROUTINE  9030  •  TRANSPORT  PRINT  CALL 

***** 

1484 

12A2 

REM 

***** 

1484 

12A2 

REM 

•••*  ARGUMENTS:  PRIMTPQS 

***** 

1484 

12A2 

REM 

NUMERIC  VARIABLE  INDICATING  THE  STARTING  PRINT  POSITION 

1484 

12A2 

REM 

••••  VALUES  =  0  THRU  90 

1484 

12A2 

REM 

*««« 

***** 

1484 

12A2 

REM 

••••  ARGUMENTS:  PSTRINGS 

***** 

1484 

12A2 

REM 

*•••  TEXT  TO  BE  PRINTED  ON  THE  FORM 

1484 

12A2 

REM 

1484 

12A2 

REM 

•***  MOTE:  THIS  ROUTINE  HAS  NO  EFFECT  UNLESS  THE  SCAN 

1484 

12A2 

REM 

*•••  HEADER  SHEET  IS  MARKED  'PRINTER  ON' 

1484 

12A2 

REM 

1484 

12A2 

9030 

REM 

1485 

12A2 

ERRSTATS  ®  SPACE$<60) 

1491 

12A2 

RECOROPTR  *  VARPTRCSHEETRECCO)) 

1498 

12A2 

CALL  TPRINT(PRINTPOS,PSTRINGS,ERRSTATS) 

14A0 

12A8 

IF  ASC(ERRSTAT$)  <>  64  THEN  ERRMSG$="PR I  NT  ERROR  "♦ERRSTATS 

14C9 

12A8 

GOTO  9100 

14C0 

12A8 

14C0 

14D0 

12A8 

12A8 

9100 

RETURN 

1400 

12A8 

1400 

12A8 

ncn 

1400 

12A8 

25000 

REM  USER  TERMINATED  INPUT...  FILE  IS  HOT  TO  BE  USE0!!H! 

1401 

12A8 

LPRINT  "USER  TERMINATED  INPUT  ..  DATA  URL  HOT  BE  USED!" 

1409 

12A8 

LPRINT  "ERASING  FILE  ";0ATFILS 

14E6 

12A8 

BEEP 

14EA 

12A8 

CLS  :  PRINT  "USER  TERMINDATED  INPUT  ..  DATA  URL  NOT  BE  USED! 

II 

14F6 

12A8 

CLOSE 

UFA 

12A8 

OPEN  DATFRS  FOR  OUTPUT  AS  «1 

150C 

12A8 

PRINT  #1,STRINGS(RECOROLENGTH,"X")  'VOID  THE  FIRST  RECORD 

151E 

12A8 

CLOSE 

1522 

12A8 

RACP820 

EKG  (DOAA)  FORM 


Offtet 

Data 

Source  Line 

1522 

12A8 

30000  REM 

1523 

12A8 

CLOSE 

1527 

12A8 

CHAIN  "RACP10“ 

152E 

12A6 

END 

1532 

12Aa 

1535 

12AS 

22151  Bytes  Available 
16573  Bytes  Free 

0  Warning  Error{s> 
0  Severe  Error(s) 
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4 


PAGE  1 

07-06-8?  _ 

U:57:17  J 

IBM  Personal  Computer  BASIC  CompUrr  VI. 00 


001A 

0002 

001A 

0002 

301A 

0002 

001A 

0002 

001A 

0002 

REM  SLJNESIZE:  132 
REM  SPAGESIZE:  66 
REM  STITLE:  ‘RACPBSO  ■ 

REN  SSUBTITLE:  'EMERGENCY  ROOM  FORM  DESTRING/OECOOE  PROGRAM' 
REM  SPACE 


i 


UCP830 

EMERGENa  ROOM  FORM  DESTRING/DECOOE  PROGRAM 


Offset 

001A 

OOU 

001A 

001A 

001A 

001A 

001A 

001A 

001A 

001A 

001A 

001A 

001A 

001A 

001A 

OOU 

001A 

OOU 

OOU 

OOU 

OOU 

OOU 

OOU 

OOU 

OOU 

OOU 

OOU 

OOU 

OOU 

OOU 

OOU 

OOU 

OOU 

OOU 

OOU 

OOU 

OOU 

OOU 

OOU 

OOU 

OOU 

OOU 

OOU 

OOU 

OOU 

OOU 

OOU 

OOU 

OOU 

OOU 

OOU 

OOU 

001A 

OOU 


j 
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0002 

0002 

0002 

0002 

0002 

0002 

0002 

0002 

0002 

0002 

0002 

0002 

0002 

0002 

0002 

0002 

0002 

0002 

0002 

0002 

0002 

0002 

0002 

0002 

0002 

0002 

0002 

0002 

0002 

0002 

0002 

0002 

0002 

0002 

0002 

0002 

0002 

0002 

0002 

0002 

0002 

0002 

0002 

0002 

0002 

0002 

0002 

0002 

0002 

0002 

0002 

0002 

0002 

0002 


REM  . . . 

REM  I  NAME:  RACP830  AMBULATORY  CARE  INFORMATION  SYSTEM  | 

REM  I  DATE:  11  APR  87  EMERGENCY  ROOM  FORM  PROGRAM  j 

REM  I  0  R  BOLLING  j 

REM  . . . 

REM  EMERGENCY  ROOM  FORM  OMR  INPUT  PROGRAM 

REM 

REM  This  prograa  reads  the  base  fona  OMR  data,  converts  various 
REM  fields,  prints  an  error  report  and  produces  the  file: 

REM 

REM  VISIT.DAT 

REM 

REM  for  input  to  FOCUS.  NOTE  THAT  THIS  FILE  IS  OPENED  FOR  APPEND 
REM  each  time  the  program  is  run.  Thus,  if  the  file  does  not  exist, 

REM  records  will  be  added  to  the  front.  If  the  file  exists,  records 
REM  will  be  added  to  the  end  of  Che  current  file.  It  is  intended  that 
REM  the  FOCUS  DIALOGUE  MANAGER  ROUTINE  which  loads  the  data  will  delete 
REM  the  data  file  after  the  load  has  been  successfully  secoaplished. 

REM 

REM  If  there  Is  no  valid  user  logged  at  the  time  of  execution,  this 
REM  program  will  chain  to  the  logon  program  RACPOS,  otherwise, 

REM  the  program  chains  to  program  RACP10  on  exit. 


REM  SINCLUOE:  ‘RACOIM.MOO*  REM  INCLUDE  THE  DIMENSION  DEFINITIONS 

••  NAME:  RACOIM.MOO  DIMENSION  DEFINITIONS  • 

'*  Date:  28  Feb  8A  Written  fay:  Floyd  Cole  * 

••«****««***«***«*****•****•**••••**•**••*••«****•••«********«•*•**«*** 

'  Dimensioned  variables  are  defined  in  this  file. 

'  It  is  an  included  file  so  it  cannot  be  run  in  a  stand-alone, 

'  mode. 


This  program  segment  may  be  modified,  but  all  files  containing 
an  include  for  this  segment  must  be  re-compiled  in  order  to 
affect  the  changes  made  here. 

••*•••<•«•••  start  of  dimension  definition 


DEFINT  A-Z 

DIM  USERS(2),H0LENGTH(12),DATEERRS(3) 
•*•**•••••••  END  OF  DIMENSION  DEFINITIONS 


REM  DIMENSION  STATEMENTS  UNIQUE  TO  THIS  PROGRAM. 


DIM  SHEETREC(1750) 

DIM  PROTOCOL! 7) 

DIM  YN$(3) 

DIM  E0.MSGS(30) 

DIM  CLINIC1.PFX$(5) 
DIN  CLINIC2.PFXS(6) 

DIM  PROVIDER. TIME$(22) 
DIM  PROCEDt(125) 

DIM  0IACN.TABt(225) 


'(MAX.  SIZE  FOR  A  SHEET  FROM  THE  SCANNER) 
■(ARRAY  FOR  SERIAL  BOARD  SETUP  PARAMETERS) 
'(YES/HO  ANSWERS  0*7.  1  *  Y  ,  2=N  ,  3=X) 
'(ERROR  MESSAGES  FROM  EDIT  ROUTINES) 
'(PREFIX  -B  0  F  G  S-  FOR  CLINIC  «1) 

'(PREFIX  -A  8  C  D  F  S-  FOR  CLINIC  #2) 
■(TIME  TABLE  FOR  PROVIDERS) 

■(PROCEDURE  TABLE  FOR  BASE  FORM) 
■(DIAGNOSIS  TABLE  FOR  BASE  FORM) 


UCP830 

EMERGENCY  ROOM  FORM  DESTRING/DECOOE  PROGRAM 


OfftRt 

001A 
001A 
001A 
001A 
001A 
0O1A 
OOU 
001A 
001A 
001A 
0O1A 
0O1A 
001A 
0O1A 
001 A 
301A 
001A 
001A 
001A 
001A 
001A 
001A 
001A 
001A 
001 A 
001A 
001A 
001A 
001A 
001A 
001A 
001A 
OOU 
noiA 
001A 
001A 
001A 
001A 
OOU 
OOU 
OOU 
OOU 
OOU 
0048 
004F 
0056 
0C50 
0064 
0068 
0077 
0077 
007E 
0085 
C08C 
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0002 

0002 

0002 

0002 

0002 

0002 

0002 

0002 

0002 

0002 

0002 

0002 

0002 

0002 

0002 

0002 

0002 

0002 

0002 

0002 

0002 

0002 

0002 

0002 

0002 

0002 

0002 

0002 

0002 

0002 

0002 

0002 

0002 

0002 

0002 

0002 

0002 

0002 

0002 

0002 

0002 

0002 

0002 

1624 

1624 

1626 

1626 

1626 

1626 

1626 

1626 

1626 

1626 

1626 


DIM  H0LDS<99)  '(HOLD  AREA  FOR  SUBROUTINE  6000) 

DIM  SPECLS(09)  '(SPECIAL  PROGRAMS) 


REM  SINCLUDE:  'RACCMN.MOO' 


REM  INCLUDE  THE  COMMON  AREA  DEFINITION 


COMMON  AREA  DEFINITION 
Written  by:  Floyd  Cole 


NAME:  RACCMN.MOO 
Date:  28  Feb  84 

*****•****»*********<****** *>»»■*»*»**•»*********»»»*»»»*»♦»****«** 

COMMON  AREA  DEFINITIONS  WILL  BE  HELD  IN  THIS  FILE.  IT  IS  AN 
INCLUDED  FILE  SO  IT  CANNOT  BE  RUN  IN  A  STANDULONE,  MODE. 

This  program  segment  may  be  modified,  but  all  files  containing 
an  include  for  this  segment  must  be  re*conpiled  in  order  to 
affect  the  changes  made  here. 


••••••••••••‘START  Of  COMMON  DEFINITIONS^^ 


COMMON  FORE,BACK,BOARD,HIDE,EFaRE,EBACX,BELLS  'BASIC  SCREEN  COLORS 
COMMON  HEADERS  '21  CHARACTER  SCANNER  HEADER  INFO 

COMMON  TEXTS  "  AINING  CHARACTERS  FROM  SCANNER 

COMMON  PGMIDS  'PROGRAM  OR  FORM  ID 

COMMON  MOLENGTHO  'DAYS  IN  THE  MONTH 

COMMON  USERS! ) 

••“•••••••••END  OF  COMMON  dEFINIT10N“*«»“‘““““““““ 


REM  SINCLUDE:  'RACOEF.MOO'  REN  INCLUDE  THE  DEFAULT  DEFINITIONS 

i********e**********************»***********************************i 

••  NAME:  RACP01.0EF  DEFAULT  DEFINITIONS 

'•  Date:  28  Feb  84  Written  by:  Floyd  Cole 

i**********««*«*****«««***-***««**«««**«****««*****'*«*««*******e*****i 

'  Variables  used  in  common  that  have  a  default  value  on  start*up 
'  will  be  held  in  this  file.  It  is  an  included  file  so  it  cannot 

'  be  run  in  a  stand*alone  mode.  In  normal  operation,  this  file 

'  should  be  'included'  in  the  main  program  only  (RACP10.BAS). 

I 

'  This  program  segment  aiay  be  modified,  but  all  files  containing 
'  an  include  for  this  segment  must  be  re‘compiled  in  order  to 
'  affect  the  changes  made  here. 


•••••••••••••START  OF  DEFAULT  DEFINITION“““*“ 

FORE  a  15  'FOREGROUND  COLOR  ^  INTENSE  WHITE 

BACK  *  1  'Background  Color  >  Li^t  Blue 

BORD  X  4  'BORDER  «  RED 

HIDE  3  4  'ALTERNATE  COLOR  <  RED 

EFORE<  14  'ERROR  FOREGROUND  DISPLAY 

EBACKa  0  'ERROR  BACKGROUND  DISPLAY 

BELLS  n  CHRS(7)  'Sound  the  bell 


MOLENGTHd) 

»  31 

■JAN 

M0LENGTH(2) 

=  28 

'FEB  <--MOOIFIEO  IN  SUBROUTINE  RACS5000.SUB 

MOLEMGTH(3) 

=  31 

'MAR 

M0LENGTH(4) 

=  30 

■APR 

RACPB30 
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0093 

1626 

005A 

1626 

OOA1 

1626 

OOA8 

1626 

OOAF 

1626 

0OB6 

1626 

OOBO 

1626 

00C4 

1626 

OOCB 

1626 

OOCB 

1626 

00D4 

1626 

0000 

1626 

00E6 

1626 

OOEF 

1626 

OOEF 

1626 

00F6 

1628 

OOFF 

162C 

OOFF 

162C 

OOFF 

162C 

OOFF 

162C 

OOFF 

162C 

0105 

162C 

0105 

162C 

0105 

162C 

0105 

162C 

0105 

162C 

0105 

162C 

0105 

162C 

0117 

162C 

0129 

162C 

013B 

162C 

OUD 

162C 

015F 

162C 

0171 

162C 

01 7A 

162C 

01 7A 

162C 

01 7A 

162C 

01 7A 

162C 

0183 

162C 

018C 

162C 

0195 

162C 

019E 

162C 

01A7 

162C 

01  BO 

162C 

01 B9 

162C 

01 C2 

162C 

01CB 

162C 

0104 

162C 

0100 

162C 

01 E6 

162C 

01EF 

162C 

01 F8 

162C 

0201 

162C 

020A 

162C 

MOLENGTH(5) 

31 

•MAY 

MOLEMGTH(6) 

30 

‘JUN 

MOLENGTH(7) 

31 

■JUL 

MOLENGTH(8) 

31 

'AUG 

MOLENGTH(9) 

30 

•SEP 

MOLENGTH(IO) 

31 

•OCT 

MOLENGTHdl) 

30 

•NOV 

MOLENGTH(12) 

31 

•DEC 

DATEERRS(O) 

M  II 

DATEERRS(I) 

"INVALID  month* 

OATEERRS(2) 

"INVALID  DAY  " 

DATEERRS(3) 

"OAY 

TOO  LARGE  FOR  MONTH  COOED" 

MAXLENGTH 

M 

80 

•MAXItRJM  LENGTH  OF  OUTPUT  RECORD 

PADS 

S 

•PAD  CHARACTER  FOR  SHORT  RECORDS 

•ENO  OF  DEFAULT  DEFINITION*******®************#*** 

KEY  OFF 


REM  PROGRAM  PARAMETERS 


REM  •••  ENCOUNTER  FORM  CLINIC  PREFIX  TABLE  ••• 


REM  CLINIC  #1 

CLINIC1.PFX$(0)»"  " 
CLINIC1.PfXSL1)»''B« 
CLINIC1.PFXS(2)="D" 
CLIMIC1.PFXS(3)*"F“ 
CLINIC1.PFX$(4)*"G" 
CLINIC1.PFX${5)="S" 


CLINIC  #2 

CLINIC2.PFX$(0)<"  • 
CLINIC2.PFXS{1).»A« 
CLINIC2.PFX$(2)>"B” 
CLINIC2.PFX$(3)»"C" 
CLINIC2.PFXS(4)«"0" 
CLINIC2.PFX$<5)*"F" 
CLINIC2.PFX$(6)="S" 


REM  •••  ENCOUNTER  FORM  PROVIDER  TIME  TABLE  ••• 


PROVIDER, TIMES(00)»»000" 

'  NO  TIME 

PROVIDER. TIME$(01)*"002" 

•  2  MINUTES 

PROVIDER .  T I  ME$(  02 ) ="005 '• 

'  5  MINUTES 

PROVIDER. TIMES(03)="010" 

'  10  MINUTES 

PROVIDER.TIMES(04)="015" 

•  15  MINUTES 

PROVIDER. T1MES(05)="020" 

'  20  MINUTES 

PROVI DER . T IME${ 06)="030" 

•  30  MINUTES 

PROVIDER. TIHES(07)=«045" 

'  45  MINUTES 

PROVIDER. TIMES(08)="060" 

•  1  HOUR 

PROV I DER . T I HE$( 09) ="090" 

'  1  HOURS/30  MINUTES 

PROVIDER. TIME$(10>="120« 

•  2  HOURS 

PROVIDER. TIME$(11)="150" 

'  2  HOURS/30  MINUTES 

PROVIDER. TIME$(12)="180" 

'  3  HOURS 

PROVIDER . T I ME$< 1 3 ) ="21 0" 

'  3  HOURS/30  MINUTES 

PROV 1 DER . T I ME$( 1 4 )="240" 

'  4  HOURS 

PROVIDER. TIME$(15)="270" 

•  4  HOURS/30  MINUTES 

PROVIDER. TIMEt{16)="300" 

'  5  HOURS 
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OfftRt 

0213 
021 C 
0223 
022E 
0237 
0240 
0249 
0249 
0249 
0260 
0260 
0260 
027F 
027F 
0286 
0280 
0298 
0298 
a29F 
02A6 
02A6 
02AF 
0288 
0288 
0288 
02C6 
02C6 
0207 
0200 
02FS 
0311 
0320 
0327 
0327 
0327 
0335 
0335 
0346 
034C 
0364 
0380 
u390 
0397 
0397 
0397 
0397 
0377 
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162C 

PROVIDER. TIMES(17)>*330"  • 

5  HOURS/30  MINUTES 

162C 

PROVIDER. T1ME$(18}«‘‘360«  • 

6  HOURS 

162C 

PROVIDER. TIME$<19)»“390"  « 

6  HOURS/30  MINUTES 

162C 

PROVIDER. TIMES(20)*'>420"  • 

7  HOURS 

162C 

PROVIDER. T1MES(21)<«4S0«  • 

7  HOURS/30  MINUTES 

162C 

PROVIDER. T1ME$(22)>"480«  • 

8  HOURS 

162C 

162C 

REM  YES/NO  TABLE 

162C 

YNS(0)>>  "  ;  YNS<1)««Y«  :  YNS(2)»“N"  :  YN$(3)»"X“ 

162C 

162C 

162C 

REM 

PNUM»VAL(PGMIDS)/10 

162E 

REM  LENGTH  OF  STRING  RECEIVED  FROM  THE  OMR. 

a  •  a 

162E 

HEADER  >  21 

1630 

RESPONSE*  450 

1632 

RECOROLENGTH  -  HEADER  *  RESPONSE 

1634 

1634 

N.PROC  «  71  •  HUMBER  OF  PROCEDURES  FOR  THIS  FORM 

1636 

N.OIAG.COLaA  •  NUMBER  OF  OK  COLUMNS  ON  THIS  FORM 

1638 

1638 

OATFILS  «  "VISIT.OAT"  'FILE  TO  BE 

INPUT  TO  FOCUS 

163C 

BTIMES=TINES  'SCAN  START  TIME 

1640 

1640 

REM 

*•*  ENCOUNTER  FORM  PROCEDURE  TABLE 

#*• 

1640 

F.NAH£$="RACPROC."  ♦  POMIDS 

1644 

1644 

OPEN  F. NAMES  FOR  INPUT  AS  «3 

1644 

FOR  1600=0  TO  125 

1644 

INPUT  #3,PROCEDS(I600) 

1646 

IF  PROCE0S(I600)="ZZZ2Z"  THEN  GOTO  4 

1646 

NEXT  1600 

1646 

4 

CLOSE  «3 

1646 

1646 

REM 

**•  ENCOUNTER  FORM  DIAGNOSIS  TABLE 

•** 

1646 

F.NAMES=«RACDIAG."  *  PGMIDS 

1646 

1646 

OPEN  F. NAMES  FOR  INPUT  AS  «3 

1646 

FOR  1600  =  0  TO  225 

1646 

INPUT  «3,DIAGN.TABS(I600) 

1646 

IF  DIACN.TABS(I600)=«ZZZZZ'' 

THEN  GOTO  6 

1646 

NEXT  1600 

1646 

6 

CLOSE  «3 

1646 

1646 

REM 

INCLUDE:  'UCACAMP.OPT'  INCLUDE  THE  OUTP  OCA  VALIDATE  TABLE 

1646 

REM 

INCLUDE:  'UCACAMP.IPT*  INCLUDE  THE  INP  UCA  VALIDATE  TABLE 

1646 

1646 

REM  SPACE 
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0397  1646  SOSUB  1000  'MAKE  SURE  THEY  ARE  LOGGED  ON 

039C  1646  CIS 

03AO  1646  GOSUB  7000  'PRINT  SCREEN  HEADING 

03AS  1646 

03AS  1646  REM 

03AS  1646  REM 

03AS  1646  REM 

03A5  1646  REM 

03A5  1646 

0387  1646 

0387  1646  REM 

0387  1646  REM 

0387  1646  REM 

0387  1646 

03C2  1646 

03CC  1646 

0308  1648 

030F  1648 

03F4  1648 

040A  1648 

040A  1648  REM 

040A  1648  REM 

040A  1648  REM 

040A  1648  REM 

040A  1648 

040F  1648 

0429  164C 

0429  164C  REM  START  SCANNER  (SI) 

0429  164C  CNTRLOPT  •  1  :GOSU8  9010 

0435  164E  IF  ERRMSGS  >  •<  ••  THEN  LPRINT  ERRMSGS  :  GOTO  30000 

044F  164E 

044F  164E  LOCATE  22,25:PRIMT  "PRESS  'ESC  TO  TERMINATE  SCANNING  ■ 

0464  164E  REAOTYPEO  'FIRST  TINE  IN..  SCANNER  IS  STARTED.. 

0468  1650 

0468  1650  REM 

0468  1650  REN 

0468  1650  REM 

0468  1650  REN 


046B 

1650 

0468 

1650 

10  REM  -  RETURN  POINT  TO  READ  NEXT  SHEET 

046C 

1650 

046C 

1650 

AS: INKEYS 

0475 

1654 

IF  AS=CHRS(27)  THEN  GOTO  25000 

0488 

1654 

0488 

1654 

C0SU8  9020 

'SCAN  SUBROUTINE  -  GET  A  RECORD 

0490 

1654 

IF  MIDS(ERRSTAIS,14,3)="415"  THEN  GOTO  25000 

04AC 

1658 

04AC 

1658 

TEXTS="" 

'CLEAR  THE  INPUT  AREA 

0485 

1658 

GOSUB  8000 

'DECODE  HEADER 

04BA 

1658 

GOSUB  8050 

'CHECK  FOR  END  OF  J08/EN0  OF  BATCH 

04BF 

1658 

GOSUB  8200 

'DECODE  THE  RESPONSE  POSITIONS 

04C4 

1658 

LITHOS  »  MID$(TEXTS,22,8) 

04D6 

165C 

GOSUB  8070 

'CHECK  FOR  SCANNER  ERRORS 

0408 

165C 

GOSUB  8100 

'PRINT  THE  DATA  ON  THE  SCREEN 

«**««*•««****•*******•**  ******************************************* 

COMMUNICATIONS  SETUP  ***• 


PROTOCOL 
GOSUe  9001 

IF  ERRMSGS  >  "  "  THEN  LPRINT  ERRMSGS  :  GOTO  30000 


e***********************************  »»* •*»*•**  *  >  *  *  *  **#»*»*»***»»♦» 

CLEAR  AND  DISPLAY  PROGRAM  SCREEN 

»******«**********«*******»»«******«*«*»**»******«<i»»*«»«»****»<i»* 

LPRINT  CHRSdS); 

WIDTH  "LPT1;",160 

PAGE  «  0  :  GOSU8  7100  'LINE  PRINTER  HEADING 
COLOR  14 

LOCATE  11,26  :  PRINT  "EMERGENCY  ROCM  ENCOUNTER  FORM  " 

COLOR  FORE, BACK, 80R0 


OPEN  DAT FILS  FOR  APPEND  AS  *1 
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OAEO  16SC 

04E0  165C  REM  SINCLUDE:  'RACMBSO.nOI •  INCLUDE  THE  READ  FORM  REFORMAT/EDIT  MOO 

04€0  16SC  REM 

(KEO  J65C  REM  AM8UUT0RY  CARE  INFORMATION  SYSTEM  ’1  APR  87 

OAEO  165C  REM  ****  D  R  BOLLING  **•* 


OAEO  16EC  REM  MODULE  NAME  :  RACREAO.MQO 

04E0  165C  REM  ****  SCANNER  PROGRAM  «  :  EMERGENCY  RM  FORM  **** 

04E0  165C  REM 

04E0  165C  REM  PURPOSE  :  REFORMAT/EDIT  THE  FORM 

04E0  165C  REM 

OAEO  165C  REM  •*♦****»*******»**»**♦»««»*»»»»•*  »*<■*>»■ 

04EO  165C  REM  •••*  RESERVED  LINE  NUMBERS  100-199 


OAEO  165c  REM  *************»«»******«***■**»• **»»*»»*<i*«*a******»»***»»***»****** 

OAEO  16SC 

OAEO  165C  N.ERR  >0  'COUNTS  THE  NUMBER  OF  ERRORS 

0AE7  16SE 

0AE7  165E  REM  LITHO  CODE  DONE  IN  BAS  PROGRAM 

0AE7  165E  REM  *•*  CLINIC  ID  (PREFIX  ♦  CODE) 

0AE7  USE  100  CL1.C00$=“BIYA"  'DEFAULT  CLINIC  CODE 

OAFO  1662 

OAFO  1662  REM  VISIT  DATE 

OAFO  1662  10A  CMS^I0S(DATES,1,2I  'CURRENT  MONTH 

0502  1666  YR$*MIDS<DATES,9,2)  'CURRENT  YEAR 

051A  166A  XS*MI0S(TEXTS,35,A)  'MONTH  AND  DAY 

0526  166E  IF  LEFT$(X$,2)<»CM$  THEN  105  'OX,  USE  THIS  YEAR 

053B  166E  YRS«RIGHTS(STR$(VAL(YRS)-1),2}  'USE  LAST  YEAR 

0558  166E  105  VIOATE$=YRS+X$ 

0569  1672  D1$*MI0$(X$,3,1) 

057B  1676  02$=MI0$(X$,A,1) 

0580  167A  IF  01$="  «  AND  02$<>’“  «  THEN  RT.5000=2  :  GOTO  106 

05BB  167C  IF  D1$<>"  "  AND  02$="  "  THEN  RT. 5000=2  :  GOTO  106 

05E9  167C  'EDIT  VISIT  DATE 

05E9  167C  CX.5000$=VIDATE$ 

05F2  1680  G0SU8  5000  'DATE  CHECX 

05F7  1680  IF  RT. 5000=0  THEN  GOTO  107 

0606  1680  106  N.ERR=N.ERR+1 

060E  1680  ED.MSG$(N.ERR}="VISIT  DATE"  *  DATEERR$(RT.5000) 

063A  1680 

063A  1680  REM  •••  PRIMARY  PROVIDER 

063A  1680  107  PPROV.PFX$=MIO$<TEXT$,39,1) 

06A6  168A  PPROV.NUM$=MIO$(TEXr$,AO,A) 

0658  1688 

0658  1688  REM  PATIENT  SSH  **• 

t558  1688  108  SSN$  =  MID$(TEXT$,AA,9) 

066A  168C 

066A  168C  REM  ♦**  FAMILY  MEMBER  PREF  ••• 

066A  168C  110  FHEMP$=MID$(TEXT$,53,2) 

067C  1690 

067C  1690  REM  *•»  FORM  NUMBER  ••• 

067C  1690  FRMN$=LEFT${PGMID$,2) 

0688  169A 

0608  169A  REM  **•  VISIT  COUNT  *•* 

0608  169A  112  VCNT$="1" 

rWA  1698 


•BY  DEFAULT 
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Offset 

Data 

Source  Line 

0694 

1698 

REM 

PRIMARY  PROVIDER  TIME  *** 

0694 

1698 

113 

X»VAL(MI0${TEXT$.56,2)) 

06AA 

169A 

PPROV.TIM$«PROVIOER.TIME$(X) 

068C 

169E 

06BC 

169E 

REM 

SECCMOARY  PROVIDER 

068C 

169E 

SPROV .PFX$*M I0i<  TEXTS , 58 , 1 ) 

06CE 

16A2 

SPROV. NUM$*M I D$( TEXTS , 59, 4 ) 

06E0 

16A6 

IF  SPROV.PFXS*SPROV.MUMS  .  «  «  THEN  SPBL«1  ELSE  SPBL^ 

0705 

16A8 

IF  SPROV.PFXS^"  "  AND  SPROV.NUMS  <>  «  ■  THEN  114 

072B 

16A8 

IF  SPROV.PFXSo"  "  AND  SPROV.NUtt  =  "  ■  THEN  114 

0751 

16Aa 

GOTO  115 

0755 

16A8 

0755 

16A8 

114 

N.ERR  <  N.ERR  «  1 

0750 

16A8 

EO.MSGS(N.ERR)>‘‘PROV  2  CODE  MISSING  PREFIX  OR  NUMBER" 

0771 

16A8 

0771 

16Aa 

REM 

•**  SECOMOARY  PROVIDER  TIME 

0771 

16A8 

115 

X>VAL(MI0S(TEXTS,63,2)) 

0787 

t6A8 

SPROV. TIMSsPROVIOER . T IHES(X) 

0799 

16AC 

REM 

1  IS  THERE  A  TIME  AND  NO  SEC  PROV  CODED? 

0779 

16AC 

IF  SPROV.TIMS  <>  "000“  AND  SP8L  ■  1  THEN  116  'GO  IF  YES 

07BC 

16AC 

REM 

IS  THERE  NO  TIME  AND  A  SEC  PROV  COOED? 

078C 

16AC 

IF  SPROV.TIMS  =  "000"  AND  SP8L  *  0  THEM  117  'GO  IF  YES 

070  F 

16AC 

GOTO  118 

07E3 

16AC 

0753 

16AC 

116 

N.ERR  >  N.ERR  *  1 

075B 

16AC 

EO.MSGS(M.ERR)="TIME  COOED  WITH  NO  SEC  PROV  COOED" 

07FF 

16AC 

GOTO  118 

0803 

16AC 

0803 

16AC 

117 

N.ERR  <  N.ERR  *  1 

080B 

16AC 

E0.HSGS(M.ERR)="N0  PROV  2  TIME" 

081 F 

16AC 

081 F 

16AC 

REM 

•••  REASON  FOR  SECONDARY  PROVIDER 

081 F 

16AC 

118 

SPROV.HEAS=MIOS(TEXTS,65 , 1 ) 

0831 

16B0 

REM 

IS  THERE  A  REASON  ANO  NO  SEC  PROV  CXEO? 

0831 

16B0 

IF  SPROV.REAS  <>  "  “  ANO  SPBL  =  1  THEN  119  'GO  IF  YES 

0854 

16B0 

REM 

IS  THERE  NO  REASON  ANO  A  SEC  PROV  COOED? 

0854 

16B0 

IF  SPROV.REAS  <>  "  "  ANO  SPBL  =  1  THEN  120  'GO  IF  YES 

0877 

16B0 

GOTO  122 

087B 

16B0 

087B 

1680 

119 

N.ERR  >  N.ERR  «  1 

0883 

1680 

EO.MSGS(M.ERR)="REASON  COOED  WITH  HO  SEC  PROV  COOED" 

0897 

1680 

GOTO  122 

089B 

1680 

0898 

16B0 

120 

N.ERR  >  N.ERR  *  1 

08A3 

1680 

EO.MSGS(M.ERR)="HO  PROV  2  REASON" 

08B7 

16B0 

0867 

1680 

REM 

IF  MOT  SCHEDULED  **• 

0887 

16B0 

122 

MOTSC$="3"  'DEFAULT  IS  3  (EMERGENCY) 

08C0 

1684 

XS=MIDS(TEXTS,66,1) 

0802 

16B4 

IF  XS="1"  THEN  NOTSC$="1"  'SCHEDULED  (FOLLOW-UP) 

08E9 

16B4 

08E9 

1684 

REM 

**•  PLACE  OF  VISIT  ••• 

08E9 

1684 

HOTCLt="1"  'DEFAULT  IS  1  (CLINIC) 

08F2 

16B8 

124 

XS=MIDS(TEXTt,67,1) 

PACE  8 
0/-CS-a7 
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Oats 

Source 

Line 

0904 

16B8 

IF  X$="1*  THEN  NOTCLS>"a"  ‘SEEM  LAST  48  HOURS 

091B 

16B8 

09IB 

16B8 

REM 

REFERRAL  COOE 

091B 

16B8 

REF.COOSa"  « 

0924 

t6BC 

0924 

16BC 

REM 

•••  JOB  RELATEO  VISIT  *•* 

0924 

16BC 

130 

RELAT.VISS«"N“ 

0920 

16C0 

IF  MI0$(TEXTS,72,1)«“1"  THEN  RELAT.VISS="Y“ 

094E 

16C0 

094E 

16C0 

REM 

MIL  ONLY  OUTY  ••• 

094E 

16C0 

132 

M I LDUT$=M 1 0$<  TEXTS , 73 . 1 ) 

0960 

16C4 

0960 

16C4 

REH 

*•*  MIL  ONLY  OTRS 

0960 

16C4 

134 

NIL0TRS‘MI0S(TEXTS,74,1) 

0972 

16C8 

0972 

16C8 

REM 

**•  MIL  ONLY  PROF 

0972 

16C8 

136 

MI LPRO$«MIO$(TEXT$, 75, 1 ) 

0984 

16CC 

0984 

16CC 

REM 

***  NOT  AVAILABLE  *** 

0984 

16CC 

138 

NAVAIL$=MI0$(TEXTS,76,1) 

0996 

1600 

0996 

1600 

REM 

SPEC  PREASSICNEO  CLINIC  **• 

0996 

1600 

140 

I NP . STOS*MI 0${ TEXTS, 77, 9) 

09A8 

1604 

GOSUB  5700  'CONVERT  ARRAY 

09AO 

1604 

SPE.BUFS-BOF.STOS  'UP  TO  9  TWO  DIGIT  COOES 

0986 

160C 

09B6 

160C 

REM 

SPEC  PROGRAMS  ••• 

0986 

160C 

REM 

•••  READ  AS  ARRAY 

09S6 

160C 

142 

INP.STOS=MIOS(TEXT$,86,7) 

09C8 

160C 

GOSUB  5700  'CONVERT  ARRAY 

09C0 

160C 

SPPROC$=BUF.STO$  'UP  TO  7  TWO  DIGIT  COOES 

0906 

16E0 

0906 

16E0 

REM 

PROVIOER  2  AOOL  PROC  1 

0906 

16E0 

144 

PR2PRC1S="N'' 

090F 

16E4 

IF  MID$(TEXT$,93,1)="1"  THEN  PR2PRC1S=»Y" 

OAOO 

16t4 

OAOO 

16E4 

REM 

•••  ADDITIONAL  PROCEDURE  1 

OAOO 

16E4 

146 

AOOP 1 $=M I D$( TEXTS , 94 , 5 ) 

0A12 

16E8 

0A12 

16E8 

REM 

PROVIDER  2  ADDL  PROC  2 

0A12 

16E8 

148 

PR2PRC2S="N" 

0A1B 

16EC 

IF  MIDS(TEXT$,99,1)*"1"  THEN  PR2PRC2S=«"Y" 

0A3C 

16EC 

0A3C 

16EC 

REH 

***  ADDITIONAL  PROCEDURE  2  •••• 

0A3C 

16EC 

150 

AD0P2S=M I DS<  TEXTS , 1 00 , 5 ) 

0A4E 

UFO 

oaae 

UFO 

REM 

***  ADMITTED  ••• 

uA4E 

UFO 

ADMITS=»N" 

0A57 

UF4 

IF  MI0$(TEXTS,105,1)="1''  THEM  ADMITS=“Y" 

0778 

UF4 

3A78 

UF4 

REM 

**•  EDIT  FOR  MIL  ONLY  BOX 

0A78 

UF4 

REM  ...  THE  FOLLOWING  FORMS  TO  MOT  HAVE  A  MIL  ONLY 

CA<8 

UFA 

IF  FRMNS="40"  OR  FRMNS="58"  OR  FRHN$="60"  THEN  155 

OAAS 

UFA 

If  fRMNt=’'63"  OR  FRHNS="67"  OR  fRMNS="76"  THEN  155 
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0AO8 

16F4 

REM  ...  DO  EDITS  ON  FMP>20  ONLY 

OA08 

16F4 

IF  FMEMP$<>“20“  THEM  155 

0AE6 

16F4 

REM  ...  IS  DUTY  COOED 

0AE6 

16F4 

IF  MILDUTSo"  THEN  152  'GO  IF  DUTY  IS  COOED 

0AF4 

16F4 

REN  ...  IS  QTRS  COOED 

0AF4 

16f4 

IF  MILOTRSo*  "  THEN  152  'GO  IF  YES  TO  CHECK  FOR  ERROR 

0802 

16F4 

REN  ...  IS  ADMITTED  COOED 

0B02 

16F4 

IF  ADMITS^OY"  THEN  155  ‘IF  YES  THEN  DO  NOTHING 

0B10 

16F4 

MILOUT$«"1“  'SET  TO  DUTY  BY  DEFAULT 

0B19 

16F4 

GOTO  155 

0B1D 

16F4 

OBID 

16F4 

152 

REM  ...  IS  ADMITTED  COOED 

0B1E 

16F4 

IF  A0MITt»"N"  THEN  155  'OK 

0B2C 

16F4 

0B2C 

16F4 

REM  ...  ERROR  DUTY,  QTRS  AND  ADMITTED  CANNOT  ALL  BE  COOED 

0B2C 

16F4 

N.ERR  >  N.ERR  *  1 

0B34 

16F4 

ED.NSGS(N.ERR)>"DUTY  OR  QTRS  CANNOT  BE  COOED  WITH  ADMITTED" 

0B48 

16F4 

0B48 

16F4 

REM 

UNLISTED  PRIMARY  DX 

0B48 

16F4 

155 

X«VAL(MIO$(TEXTS, 106,1)) 

08SE 

16F4 

IF  X»0  THEN  PRIMOXS«““ 

0872 

16f8 

IF  X»1  THEN  PRIMDX**"V" 

0B86 

16F8 

IF  X:2  THEN  PR1M0XS>"S" 

0B9A 

16F8 

DXTMP$«MID$<TEXT$,107,5) 

OBAC 

16FC 

IF  DXTMP$«"  "  THEN  GOTO  158 

OBBE 

16FC 

OBBE 

16FC 

REM  REMOVE  LEADING  BLANKS 

OBBE 

16FC 

156 

IF  LEFT$(0XTMPS,1)="  "  THEN  0XTMP$=RIGHT$(DXTMP$,4)+«  ":GOTO  156 

OSEO 

16FC 

OBEO 

16FC 

158 

LASTC$=RIGHT$(DXTMP$,1)  'GET  LAST  CHAR 

OBFC 

1700 

IF 

LASTCSo"  "  AND  LASTC$<>"0"  THEN  PRIM0X$=""  'REMOVE  V  OR  S 

0C28 

1700 

PR1MOX$=LEFT$(PRIMOX$+OXTMPS,5)  'GET  5  CHAR  ONLY 

0C3A 

1700 

0C3A 

1700 

REM 

**•  UNLISTED  SECONDARY  OX 

0C3A 

1700 

160 

X^VALCMIDSCTEXTS, 112,1)) 

OC50 

1700 

IF  X*0  THEM  SEC0X$="" 

0C64 

1704 

IF  X=1  THEN  SECOX$="V" 

0C78 

1704 

IF  X=2  THEN  SECDX$="S" 

0C8C 

1704 

DXTMP$=MIO$(TEXT$, 113,5) 

0C9E 

1704 

IF  DXTMPSs"  "  THEN  GOTO  164 

OCBO 

1704 

0C80 

1704 

REM  REMOVE  LEADING  BLANKS 

OCBO 

1704 

162 

IF  LEFTS(DXTMP$,1)="  "  THEN  0XTMP$=RIGHTS(0XTMP$,4)+"  ":GOTO  162 

OCOF 

1704 

OCOF 

1704 

164 

LASTCS=RIGHT$(DXTMP$,1)  'GET  LAST  CHAR 

OCEE 

1704 

IF 

LASTCSo"  "  AND  LASTC$<>"0"  THEM  SECDXS=""  'REMOVE  V  OR  S 

0O1A 

1704 

SECOXS=LEFTS(SECDX$*OXTMP$,5)  'GET  5  CHAR  ONLY 

002C 

1704 

002C 

1704 

REM 

FOLLOW  UP/RULE  OUT  ••• 

002C 

1704 

166 

FU.RO$*MIDS{TEXT$, 118,1) 

003E 

1708 

0O3E 

1708 

REM 

•**  EVALUATION/SERV/PROC  PROV  1  »*• 

003E 

1708 

168 

INP.STO$=MIOS(TEX1S,119,N.PROC) 

0051 

1708 

ESP.BUF1$="" 

PACE  10 
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OOSA 

170C 

N.ST0=1 

X61 

170E 

0061 

170E 

170 

X.ST0=IMSTR(M.ST0,INP.ST0$,«1«) 

0073 

1710 

IF  X.STO»0  THEM  GOTO  172  'THATS  ALL 

0082 

1710 

M.STO=X.STO  ♦  1  'NEXT  STARTING  POINT 

0O8A 

1710 

ESP.BUFIS^ESP.BUFIS  *  PROCEDS(X.STO)  'ADD  CODE  TO  BUFFER  BY  FIVES 

009F 

1710 

IF  H.STO  <S  LEN(INP.STOS)  THEM  GOTO  170 

0DB2 

1710 

OOB2 

1710 

REM 

EVALUATION/SERV/PROC  PROV  2  *** 

OOB2 

1710 

172 

INP.STOS=MIOS(TEXTS,119«N.PROC,M.PROC) 

00C9 

1710 

ESP,BUF2$=»" 

0002 

1714 

M.STO=1 

0009 

1714 

0009 

1714 

174 

X.STO=INSTR(M.STO,INP.STO$,"1") 

OOEB 

1714 

IF  X.STO«0  THEM  GOTO  176  ‘THATS  ALL 

ODFA 

1714 

IF  SPROV.NUMS  «  «  ••  THEN  175  'MEED  SEC  PROV  COOED 

0E08 

1714 

N.STO=X.STO  ♦  1  ‘MEXT  STARTING  POINT 

0E10 

1714 

ESP.BUF2$=ESP.BUF2S  ♦  PROCEDS<X.STO)  ‘ACD  CODE  TO  BUFFER  BY  FIVES 

0E2S 

1714 

IF  N.STO  «  LEN(INP.STOS)  THEN  GOTO  174 

0E38 

1714 

GOTO  176 

0E3C 

1714 

0E3C 

1714 

175 

N.ERR  ::  N.ERR  *  1 

0E44 

1714 

EO.MSGS(M.ERR)="PROC  CODE  FOR  SEC  PROV  BUT  NO  SEC  PROV  COOED" 

0E58 

1714 

0E58 

1714 

176 

T.POS  =  119  ♦  2*N.PROC 

0E66 

1716 

0E66 

17-6 

REM 

PRIMARY  OX  *•* 

'1E66 

1716 

REM 

•  IF  OTHER  PRIM  OX  IS  COOED  THEN  SKIP  THIS  SECTION  • 

0E66 

1716 

186 

IF  PRIMOXSo"  ••  THEN  GCTO  192 

0E78 

1716 

X.POS^T.POS  'STARTING  POSITION 

0E7F 

1718 

C1S1Z=55  :  C3SIZ=50  'NO.  OF  ITEMS  IN  EACH  COL 

nE80 

171C 

C2SIZ=63  :  C4SIZ':26 

0E98 

1720 

GOSUB  5800  'GET  POSITION 

OEAO 

1720 

IF  X.FIN=0  THEN  GOTO  188 

OEAF 

1722 

IF  RT. 5800=0  THEN  GOTO  190 

0E3E 

1724 

N.£RR=H.ERR  ♦  1 

0EC6 

1724 

ED.MSG$(N.ERR)="PRIHARY  OX  HAS  MULTIPLE  COOES" 

TEOA 

1724 

GOTO  190 

CEDE 

1724 

OEDE 

1724 

188 

N.ERR=N.ERR  *  1 

0cE6 

1724 

ED.MSGS(N.ERR)="PRIMARY  OX  NOT  COOED" 

OEFA 

1724 

OEFA 

1724 

190 

PRIHDXS=OIAGN.TABS(X.FIN) 

OFOC 

1724 

OFOC 

1724 

192 

T.POS  =  T.POS  ♦  2  •  N.OIAG.COL 

0F1B 

1724 

NDX  =  55+63+50+26- 1 

0F22 

1726 

CF22 

1726 

REM 

SECONDARY  OX  *** 

0F22 

1726 

194 

INP.STOS=MID$(TEXT$,T.POS,NDX) 

0F36 

1726 

DX2.BUF$="" 

0F.,F 

172A 

N.STO=1 

0F46 

172A 

rf(.6 

172A 

196 

X.STn=INSTR{N,STO,INP.STOS,"1") 

Of'8 

172A 

IF  X.STO=0  THEN  GOTO  197  'THATS  ALL 
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0F67  172A  M.STO=X.STO  +  1  'REXT  STARTING  POINT 

0F6F  172A  DX2.BUF$^X2.BUF$  4-  DIAGN.TABS(X.STO)  'ADD  CODE  TO  BUFFER  BY  FIVES 

0F84  172A  IF  N.STO  «  LENC INP.STOS)  THEN  GOTO  196 

0F97  172A  197  IF  SECOX$="  "  THEN  GOTO  198 

0FA9  172A  0X2.BUFS=0X2.BUFS4SEC0X$  'ADO  OTHER  SEC  DX  IF  THERE 

0FB5  172A 

0FB5  172A  198  T.POS  *  T.POS  ♦  NOX 

OFCO  172A 

OFCO  172A  IF  PGMIDS  <>  "740“  THEN  199  'SXIP  IF  MOT  PSYCHOLOGY 

OFCE  172A  REM  **•  PSYCHOMETRIC  ASSESSMENTS 

OFCE  172A  INP.STO$=MID$(TEXT$,T.POS,4) 

0FE1  172A  GOSUB  5700  'CONVERT  ARRAY 

0FE6  172A  PSYCHOS=aUF.STO$  'UP  TO  4  TWO  DIGIT  CODES 

OFEF  172E 

OFEF  172E  199  REM 

OFFO  172E  REM  . END  OF  MODULE  RACMSSO.HOI . 

OFFO  172E 

OFFO  172E  IF  H.EFR  =  0  THEM  GOTO  997 

OFFF  172E  LPRIMT  “LITHO  #  ";LITHO$;"  ...ERRORS" 

1011  172E  FOR  1997  «  1  TO  N.ERR 

101E  1730  LPRINT  USING  "im  ";I997; 

102A  1732  LPRINT  "»*>  ";E0.MSGt(1997) 

1040  1732  NEXT  1997 

1051  1732  LN. COUNT  *  LM. COUNT  ♦  N.ERR  ♦  1 

1050  1734  CNTRLOPT  -  6 


1064 

1734 

GOSUB  9010  'REJECT  THE  FORM 

1069 

1734 

GOTO  998  'BYPASS  THE  DISK  WRITER _ 

1060 

1734 

1060 

1734 

997 

REM  SINCLUOE:  'RACN830.MO2'  REM  INCLUDE  THE  BASE  FORM  DISK  WRITER 

106E 

1734 

REN 

106E 

1734 

REM 

*«** 

AMBULATORY  CARE  INFORMATION  SYSTEM  11  APR  87 

106E 

1734 

REM 

***« 

D  R  BOLLING 

**** 

106E 

1734 

REN 

***« 

MODULE  NAME  :  RACM830.M02 

**** 

106E 

1734 

REM 

«**« 

SCANNER  PROGRAM  #  :  EMERGENCY  ROOM  FORM 

*•** 

106E 

1734 

REM 

•  **« 

106E 

1734 

REM 

*«*« 

PURPOSE  :  CREATE  AND  WRITE  THE  DISK 

106E 

1734 

REN 

RECORD  FOR  INPUT  TO  FOCUS 

**•« 

106E 

1734 

REM 

«**« 

106E 

1734 

REM 

r****** 

106E 

1734 

REM 

**** 

RESERVED  LINE  NUMBERS  200-299 

106E 

1734 

REM 

106E 

1734 

106E 

1734 

REM 

BUILD 

THE  OUTPUT  RECORD 

106E 

1734 

106E 

1734 

GOSUB 

276  'BUILD  THE  RECORD  KEY 

1073 

1734 

1073 

1734 

REM 

1073 

1734 

REM 

RECORD  TYPE  "1"  -  MAIN  TRANSACTION 

**** 

1073 

1734 

REM 

1073 

1734 

1073 

1734 

GOSUB  278  'BUILD  DATA  FOR  TYPE  1 

1078 

1734 

RECOUTt  =PGMID$+"1"+RECKEY$+REC001$  'TRANSACTION  ID  PLUS 

RECORD 

1092 

1740 

COSUB  280 

1097 

1740 

PRINT  NI.RECOUTS 
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10A2 

10A2 

10A2 

1740 

1740 

1740 

••••  RECORD  TYPE  »2"  -  RECKEY  PLUS  PROCEDURE  CODE 

REH 

10A2 

1740 

REM 

10A2 

1740 

10A2 

1740 

REM 

ADD  ADDITIONAL  PROCEDURES  IF  AMY  ••• 

10A2 

1740 

IF  ADDPISo*  "  AND  PR2PRC1S*‘'N"  THEN  ESP.BUFIS^ESP.BUFIB^ADDPIS 

1004 

1740 

IF  ADDP2S<>‘'  ■  AND  PR2PRC2S>‘'N'*  THEN  ESP.BUF1$<ESP.BUF1S+ADDP2$ 

1106 

1740 

1106 

1740 

IF  ADDPISox  AND  PR2PRC1S>'‘Y"  THEN  ESP.BUF2SxESP.BUF2$+ADDPlS 

1138 

1740 

IF  AD0P2S<>»  ■■  AND  PR2PRC2$=>«Y'‘  THEN  ESP.BUF2t=ESP.BUF2S4'AO0P2S 

116A 

1740 

116A 

1740 

REN 

•••  PROCESS  PROV  1  PROCEDURES 

116A 

1740 

116A 

1740 

IF  LEN(ESP.SUF1S)=0  THEN  GOTO  206 

117B 

1740 

117B 

1740 

RPOINTsI 

1182 

1742 

202 

RECaO2$=MI0$(ESP.BUFU,RPOINT,5) 

1195 

1746 

IF  RECQ02S>"  ••  THEN  GOTO  204 

11A7 

1746 

11A7 

1746 

REC0UTt=PGMIDS*“2"+RECICEYS+''1"+REC0O2$  'TRANSACTION  ID  PLUS  RECORD 

11C7 

1746 

GOSUB  280 

11CC 

1746 

PRINT  #1,RECOUT$ 

1107 

1746 

1107 

1746 

204 

RPOINT  s  RPOINT  ♦  5 

11E1 

1746 

IF  RPOINT  <  LEN(ESP.BUF1$)  THEN  GOTO  202 

11F4 

1746 

11F4 

1746 

REH 

***  PROCESS  PROV  2  PROCEDURES 

11F4 

1746 

11F4 

1746 

206 

IF  LEN<ESP.BUF2$)sO  THEN  GOTO  212 

1205 

1746 

1205 

1746 

RPOINT=:I 

120C 

1746 

208 

REC002$sMID$<ESP.8UF2$, RPOINT, 5) 

121F 

1746 

IF  REC0O2$=”  "  THEN  GOTO  210 

1231 

1746 

1231 

1746 

RECOUT$*PGNIO$+"2"*RECKEY$+"2"+REC002S  'TRANSACTION  ID  PLUS  RECORD 

1254 

1746 

GOSUB  280 

1259 

1746 

PRINT  #1,RECOUT$ 

>264 

1746 

1264 

1746 

210 

RPOINT  =  RPOINT  +  5 

126E 

1746 

IF  RPOINT  <  LEN(ESP.BUF2$)  THEM  GOTO  208 

1281 

1746 

1281 

1746 

212 

REM  END  OF  TYPE  2  RECORDS 

1282 

1746 

REM 

1282 

1746 

REM 

•***  RECORD  TYPE  "3"  -  RECKEY  PLUS  SPECIFIC  PRE  CLINIC  COOES  •••• 

1282 

1746 

REM 

1282 

1746 

IF  LEN(SP£.BUF$)=0  THEM  218 

128F 

1746 

1'’8F 

1746 

RPOINT=1 

1296 

1746 

214 

REC003$=RIGHTS(HID$(SPE.BUF$,RP0INT,2),1) 

I2AF 

174A 

IF  REC003t-"  "  THEN  216 

1230 

174A 

12F0 

174A 

RECO<JT$=Pr,MID$  +  "3"  ♦  RECKEYS  ♦  REC003t 

',202' 

174A 

GOSJB  200 
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120C 

174A 

PRINT  #1,REC0UTS 

12E7 

174A 

12E7 

174A 

216 

RP0INT*RP0INT*2 

12F0 

174A 

IF  RPOINT  <  LEN(SPE.BUFS)  THEN  214 

12FC 

174A 

12FC 

174A 

218 

REM  EM)  OF  TYPE  3  RECORDS 

12FD 

174A 

12F0 

174A 

REM 

*«•*«***♦«***«**««**«*««•••*••*•••*«•*•««**«*•«*•**••*«*••«*««•**«• 

12FD 

174A 

REM 

RECORO  TYPE  “4“  -  RECNEY  PLUS  OTHER  COOES 

12FD 

174A 

REM 

••*«**«•••*•*•**•**«««**«***«•«**#*«****«*««***•****•*•**•#***••**• 

12FO 

174A 

12FD 

174A 

IF  LEN(OTH.BUFS)>0  THEN  GOTO  224 

130E 

174E 

13CE 

174E 

RPOINT«1 

1315 

174E 

220 

REC0O4S>MI0$(0TH.BUFS.RPOINT,51 

1328 

1752 

IF  RECa04Ss"  "  THEN  GOTO  222 

133A 

1752 

133A 

1752 

RECOUTS<PGMI0S«'<4"+RECKEYS*REC0O4S  'TRANSACTION  ID  PLUS  RECORD 

1354 

1752 

GOSUB  280 

1359 

1752 

PRINT  «1,REC0UTS 

1364 

1752 

1364 

1752 

222 

RPOINT  «  RPOINT  ♦  5 

136E 

1752 

IF  RPOINT  <  LEN(OTH.BUFS)  THEN  GOTO  220 

1381 

1752 

1381 

1752 

1381 

1752 

224 

REM  ENO  OF  TYPE  4  RECORDS 

1382 

1752 

1382 

1752 

REM 

1382 

1752 

REM 

*•••  RECORO  TYPE  "5"  •  RECKEY  PLUS  GROUP  I  DATA  •••* 

1382 

1752 

REM 

1382 

1752 

1382 

1752 

REN 

1382 

1752 

REM 

*•••  RECORO  TYPE  “6"  -  RECKEY  PLUS  SPECIAL  PROGRAMS 

1382 

1752 

REM 

1382 

1752 

IF  LEN(5PPROGS)’’0  THEN  262 

13aF 

1752 

138F 

1752 

RPOIMT=1 

1396 

1752 

258 

REC006S=R I GHTSlM I D$( SPPROGS, RPO I  NT , 2 ) , 1 ) 

13AF 

1756 

IF  REC006S*"  "  THEN  260 

13BO 

1756 

1380 

1756 

RECOUTSsPGMIOS  ♦  "6"  ♦  RECKEYS  ♦  REC006$ 

1307 

1756 

GOSUB  280 

130C 

1756 

PRINT  (II1,REC0UT$ 

13E7 

1756 

13E7 

1756 

260 

RP0INT=RP0INT*2 

13F0 

1756 

IF  RPOINT  <  LENISPPROGS)  THEN  258 

13FC 

1756 

13FC 

1756 

262 

REM  ENO  OF  TYPE  6  RECORDS 

13F0 

1756 

13F0 

1756 

REM 

13F0 

1756 

REM 

•••*  RECORO  TYPE  "7"  -  RECKEY  PLUS  SECOND  OX  CODE  **** 

13F0 

1  756 

REM 

13FD 

1756 

13F0 

1756 

IF  LEM(0X2.BUFS)=0  THEN  GOTO  268 
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me 

1756 

HOE 

1756 

RPOINT=1 

U1S 

1756 

264 

REC007»>MI0$(DX2.BUFS,RPOINT,5) 

1428 

175A 

IF  RECOOTSa"  «  THEN  GOTO  266 

U3A 

175A 

143A 

175A 

RECOUTS  =PGMI0S+"7"+RECffiY$+REC007»  ‘TRANSACTION  ID  7 

1454 

175A 

GOSUB  280 

1459 

175  A 

PRINT  *1, RECOUTS 

1464 

175  A 

1464 

175A 

266 

RPOINT  «  RPOIHT  ♦  5 

146E 

17SA 

IF  RPOINT  <  LEN(0X2.BUF$)  THEN  GOTO  264 

1481 

175A 

1481 

175A 

268 

REH  ENO  OF  TYPE  7  RECORDS 

1482 

175  A 

1482 

175A 

1482 

175  A 

GOTO  299 

1486 

175A 

K86 

175A 

REN 

1486 

175  A 

REM 

SUBROUTINE  270  -  BUILD  THE  RECORD  KEY 

1486 

175A 

REM 

******«***•*****••*«***•**«*«•««•*«*«**«**«**#******«•******•*•«*#* 

1486 

175A 

276 

RECKEYSa"" 

148F 

175  A 

148F 

175A 

REM 

CLINIC  10  (PREFIX  ♦  COO) 

148F 

175A 

RECKEYS*  CL 1. COOS 

1498 

175A 

1498 

175A 

REH 

VISIT  DATE  *** 

1498 

175A 

RECKEYSaRECKEYS*  VIOATES 

14A4 

175A 

14A4 

175A 

REM 

*•*  PRIMARY  PROVIDER 

14A4 

175A 

RECKEYS  =  RECKEYS  ♦  PPROV.PFXS  ♦  PPROV.NUMS 

14B7 

175A 

14B7 

175A 

REH 

PATIENT  SSN  •** 

14B7 

175A 

RECKEYS  a  RECKEYS  +  SSNS 

UC3 

175A 

14C3 

175A 

REM 

FAMILY  MEMBER  PREF  •** 

14C3 

175  A 

RECKEYS  a  RECKEYS  ♦  FHEMPS 

14CF 

175A 

14CF 

175A 

REM 

LITHO  CODE  *** 

14CF 

175  A 

RECKEYS  =  RECKEYS  +  LITHOS 

140B 

175  A 

140B 

175  A 

REM 

FORM  NUMBER 

1406 

175A 

RECKEYS  =  RECKEYS  ♦  FRMNS 

14E7 

175A 

14E7 

175A 

RETURN 

14EA 

175  A 

14EA 

175A 

REM 

UEA 

175  A 

REM 

•••*  SUBROUTINE  272  -  BUILD  THE  DATA  FOR  TYPE  1  •••* 

14EA 

175A 

REM 

14EA 

175A 

278 

REC001S="" 

%F3 

t75A 

14F3 

175A 

REM 

•**  VISIT  COUNT 

14'3 

175A 

REC001S  =  REC001S  ♦  VCNTS 

'4FF 

175A 

14rF 

175A 

REM 

**'  PRIMARY  PROV  TIME 

IBM  Personal  Computer  HASIC  Coets'ler  VI. 00 
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ltACP830 
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Offset 

Data 

Source  Line 

1«FF 

175A 

RECOOIS  *  RECOOIS  ♦  PPROV.TIM* 

1508 

175A 

1508 

173A 

REM 

SECONDARY  PROVIDER 

150B 

175  A 

RECOOIS  «  RECOOIS  ♦  SPROV.PFXS  ♦  SPROV.MUMS 

151E 

173A 

151E 

175A 

REM 

—•  SECONDARY  PROVIDER  TIME  **• 

151E 

175  A 

RECOOIS  >  RECOOIS  *  SPROV.TIMS 

152A 

175  A 

157a 

175  A 

REM 

•••  REASON  FOR  SECONDARY  PROVIDER 

152a 

175  A 

RECOOIS  «  RECOD1S  *  SPROV.REAS 

1536 

175  A 

1536 

175  A 

REM 

APPORIMTMENT  STATUS  **• 

1536 

175  A 

RECOOIS  «  RECOOIS  *  NOTSCS 

1542 

175  A 

1542 

175A 

REM 

REFERRAL  COOE  ••• 

1542 

175A 

RECOOIS  »  RECOOIS  ♦  REF.PFXS  ♦  REF. COOS 

1555 

175E 

1555 

175E 

REM 

*•*  PLACE  OF  VISIT 

1555 

175E 

RECOOIS  «  RECOOIS  ♦  NOTCLS 

1561 

175E 

1561 

1756 

REM 

*•*  408  RELATED  VISIT  •** 

1561 

175E 

RECOOIS  »  RECOOIS  ♦  RELAT.VISS 

1560 

175E 

1560 

175E 

REM 

MIL  ONLY  DUTY  *•* 

1560 

175E 

RECOOIS  >  RECOOIS  *  MILOUTS 

1579 

175E 

1579 

175E 

REM 

•••  MIL  ONLY  QTRS 

1579 

175E 

RECOOIS  >  RECOOIS  MILQTRS 

1585 

1756 

1585 

175E 

REM 

MIL  ONLY  PROFILE  ••• 

1585 

175E 

RECOOIS  >  RECOOIS  MILPROS 

1591 

175E 

1591 

175E 

REM 

•**  NOT  AVAILABLE  ••• 

1591 

175E 

RECOOIS  >  RECOOIS  t  NAVAILS 

1590 

175E 

1590 

175E 

REM 

ADMITTED  ••• 

1590 

175E 

RECOOIS  >  REC001S  *  ADMITS 

15A9 

175E 

15A9 

175E 

REM 

•••  INFIELD  (NOT  ON  GENERAL  FORM)  ••• 

15A9 

175E 

RECOOIS  =  RECOOIS  ♦  “  " 

15BS 

175E 

1585 

175E 

REM 

***  INJURY  (NOT  ON  GENERAL  FORM) 

15B5 

175E 

RECOOIS  »  RECOOIS  ♦  "  " 

15C1 

175E 

15C1 

175E 

REM 

PURPOSE  OF  VISIT  (NOT  ON  GENERAL  FORM) 

15C1 

175E 

RECOT1S  =  RECOOIS  ♦  "  " 

15C0 

175E 

15C0 

175E 

REM 

PRIM  FOLLOW-UP /RULE  OUT  ••• 

15C0 

175E 

RECOOIS  =  RECOOIS  ♦  FU.ROS 

1509 

175E 

1509 

175E 

REH 

•••  PRIMARY  OX  COOE 

1509 

175E 

RECOOIS  »  REC001S  ♦  PRIMOXS 

15E5 

175E 

15E5 

175E 

RETURN 

PACE  16 
07-06-87 
14:57:17 

IBM  Personal  Coaputer  BASIC  Compiler  VI. 00 


liACP830 
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Offset 

Data 

$our< 

15E8 

175E 

15E8 

175E 

REM 

15E8 

175E 

REN 

1SE8 

175E 

REM 

15E8 

175E 

280 

15F6 

1760 

1609 

1760 

160C 

1760 

160C 

1760 

299 

1600 

1760 

160D 

1760 

REM 

1600 

1760 

1600 

1760 

998 

160E 

1760 

160E 

1760 

999 

1615 

1760 

1625 

1762 

1629 

1762 

1629 

1762 

REM 

1629 

1762 

1629 

1762 

1000 

162  A 

1762 

REM 

162A 

1762 

REM 

162A 

1762 

REM 

162  A 

1762 

REM 

162A 

1762 

REM 

162A 

1762 

REM 

162A 

1762 

REM 

162A 

1762 

REM 

162A 

1762 

REM 

162A 

1762 

REM 

162A 

1762 

REM 

162A 

1762 

REM 

162A 

1762 

1001 

163C 

1762 

164  A 

1762 

166B 

176E 

1679 

176E 

1687 

176E 

168E 

176E 

16A4 

176E 

16BA 

176E 

16BE 

176E 

1-C1 

176E 

16C1 

176E 

1002 

16C5 

176E 

16CC 

176E 

•=a= 

16CC 

176E 

16CC 

176E 

2000 

6C0 

17d£ 

REM 

16CD 

176E 

REM 

16CD 

176E 

REM 

16CD 

176E 

REM 

1'CO 

176E 

REM 

PAGE  17 
07  06-87 
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IBM  Personal  Computer  BASIC  Compiler  VI. 00 


**»4r*«***«******* 

****  SUBROUTINE  230  •  PAD  THE  RECORD  TO  HAXLENCTH 

A****************************************************************** 

PAD-HAXLENGTH  -  LENIRECOUTS)  'FIND  OUT  NOW  SHORT  THE  RECORD  IS 
RECOUTS  c  RECOUTS  *  STRINGS  (PAD.  PADS)  'PAD  THE  RECORD  WITH  FILL  CHAR 
RETURN 


-END  OF  MODULE  RACM830.M02- 


IF  LNLCOUNT  >  48  THEN  GOSUB  7100  'PRINTER  HEADING 
GOTO  10 

REM  END  OF  SCAN/OECODE/WR 1 TE  LOOP  x=======»*=x.r=x=a====.=«======== 


LOGON  VERIFICATION  SUBROUTINE 
PATIENT  REGISTRATION  PROGRAM 


PATIENT  OMR  INPUT  PROGRAM 


RESERVED  LINE  NUMBERS  ARE  1001  THRU  1010 


IF  EOF(1)  THEN  1002 
INPUT  )ll1,USERt(1),0T$,TMS,PI0S 
IF  USERSd)  =  ""  THEN  1002 
IF  USERSd)  =  "*•••••"  then  1002 
CLOSE  1 

SCREEN  0,1, 0,0 
COLOR  FORE, BACK, BORD 
CLS 
RETURN 


CHAIN  "RACP05" 


•MAKE  THEM  LOG  ON  FIRST 

•MAKE  THEM  LOG  ON  FIRST 

■MAKE  THEM  LOG  ON  FIRST 


2000  REM  SINCLUOE:  'RACS2000.SUB'  INCLUDE  THE  RIPLY/OELAY  SUB 


AMBULATORY  CARE  DATA  BASE 

SUSnOlITINE  NAME 
SCAN'  TROGRAM  R 


13  APR  85 
SKIP  COLE 


RACS2000.SU3 

ALL 


***• 

**** 

***• 


RACPBSO 
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PAit  18 
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Offset 

Data 

Source  Line 

IBM  Personal  Computer  BASIC  Compiler  VI. CO 

16C0 

176E 

REM 

FUNCTION  : 

THIS  SUBROUTINE  MODULE 

**** 

16C0 

176E 

REM 

SERVERS  AS  A  WAIT  AND  REPLY 

16C0 

1766 

REM 

•*** 

ENTRY  MODULE 

*•** 

16C0 

176E 

REM 

INPUT  : 

SINGLE  KEYBOARD  ENTRY 

16CD 

176E 

REN 

*•«* 

160) 

176E 

REM 

OUTPUT  : 

KEYBOARD  ENTRY  -  UPPER  CASE 

16C0 

176E 

REM 

16C0 

176E 

REM 

««*• 

RESERVED  LINE 

16C0 

176E 

REM 

•*«* 

NUMBERS  : 

2001-2010 

160) 

176E 

REN 

•***«««««**•*••«•«**«*****•*•«**««««*«•**•«*««****«***•****•*••••** 

16C0 

176E 

2001 

REM  REPLY  FUNCTION 

16CE 

176E 

2002 

REPLY$<INKEY$  .-  IF  REPLYS^""  THEN  2002 

16E2 

1772 

REPLY=ASC(REPLYS) 

16EC 

1774 

If  REPLY 

>  90  THEN  REPLYS=CHRS(REPLY  XOR  32)  'CONVERT  TO  CAPS 

1707 

1774 

IF  REPLYS  <  "A"  OR  REPLYS  >  «Z“ 

THEM  REPLYS***?" 

1733 

1774 

RETURN 

1736 

1774 

1736 

1774 

5000  REM  SINCLUOE:  'RACSSOOO.SUB'  INCLUDE  THE  DATE  EDITOR  SUB 

1737 

1774 

REN 

««**«**«*««••«**««****«*«•««*«*««««««**#***************«***«******« 

1737 

1774 

REM 

«*•* 

AMBULATORY  CARE  DATA  BASE  13  APR  85 

•••* 

1737 

1774 

REM 

SKIP  COLE 

1737 

1774 

REM 

•«*« 

SUBROUTINE  NAME  : 

RXXS5000.SUB 

•*** 

1737 

1774 

REM 

SCANNER  PROGRAM  #  : 

ALL 

*•«« 

1737 

1774 

REM 

•*«« 

FUNCTION  : 

THIS  SUBROUTINE  MODULE 

1737 

1774 

REM 

«*•« 

PERFORMS  A  DATE  EDIT 

•*«« 

1737 

1774 

REM 

•««« 

1737 

1774 

REM 

•*«« 

INPUT  : 

DATE  TO  BE  CHECKED  MUST  BE 

1737 

1774 

REM 

«*** 

IN  THE  VARIABLE  NAMED 

*•»* 

1737 

1774 

REM 

«*•* 

'CK.5000S' 

1737 

1774 

REM 

•*«* 

IN  THE  FORMAT  "YYMMOD" 

1737 

1774 

REM 

«*«« 

1737 

1774 

REM 

«*•* 

OUTPUT  : 

'RT.5000'  IS  THE  RETURN  CODE 

1737 

1774 

REM 

**«• 

VARIABLE.  IF  THIS  VARIABLE 

1737 

1774 

REM 

**** 

CONTAINS  ANY  NUMBER  OTHER 

1737 

1774 

REM 

THAN  0.  AN  ERROR  WAS  FOUND 

•  *** 

1737 

1774 

REM 

*•«« 

IN  THE  DATE. 

*«** 

1737 

1774 

REN 

«*«* 

**«* 

1737 

1774 

REM 

RESERVED  LINE 

•**« 

1737 

1774 

REM 

«*«« 

NUMBERS  : 

5001-5009 

**** 

1737 

1774 

REM 

1737 

1774 

RT. 

5000  =  0 

173E 

1774 

CKYEAR  =  VAL(LEFTS<C)C.5000$,2))  'YEAR  NUMERIC  VALUE 

1751 

1776 

CKMONTH  °  VAL(MIDS(CK.5000S,3,2))  'MONTH  NUMERIC  VALUE 

1767 

1778 

CROAT  =  VAL(RICHT$(CK.5000$,2))  'OAY  NUMERIC  VALUE 

177A 

177A 

/ 

177A 

177A 

IF  CRHONTH  <  1  THEN  RT.5000* 

1  :  GOTO  5009 

1790 

177A 

IF  CKMONTH  >  12  THEM  RT.5000= 

1  :  GOTO  5009 

17A6 

177A 

IF  CROAT  <  1  THEN  RT. 5000=2  ;  GOTO  5009 

17BC 

177A 

IF  CROAT  >  31  THEN  RT. 5000=2  :  GOTO  5009 

1702 

177A 

1702 

177A 

REM 

LEAP  YEAR  CHECK 

1702 

177A 

M0LENGTH(2)  =  28 

1709 

177A 

IF  CKMONTHo  2  THEM  GOTO  5005  'MUST  BE  FEBRUARY 

17E8 

177A 

IF  (CKYEAR  MOO  4)  <>  0  THEM  GOTO  5005  'MUST  BE  A  LEAP  YEAR 

RACP830 

EMERGENCY  ROOM  FORM  OESTRING/DECOOE  PROGRAM 
OffMt  Data  Source  Line 


17F0 

1804 

1804 

1823 

1823 

1826 

1826 

1826 

1826 


177A 

177A 

177A 

177A 

177A 

177A 

177A 

177A 

177A 


PACE  19 
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MOLENCTH(2)  °  29 

5005  IF  CXDAY  >  MOLENGTH(CKMONTH)  THEN  RT.5000<3  :  GOTO  5009 
5009  RETURN 

REM . END  OF  SUBROUTINE  5000  . 


1826 

177A 

5500  REM  INCLUDE:  •RACS5500.SUB' 

INCLUDE  THE  OUTP  UCA  VALIDATE  SUB 

1827 

177A 

5600  REM  INCLUDE:  'RACSSOOO.SUB* 

INCLUDE  THE  IMP  UCA  VALIDATE  SUB 

1828 

177A 

5700  REN  SINCLUOE:  <RACS5700.SUB' 

INCLUDE  HAP  ONES  TO  POSITION  NO. 

1829 

177A 

REN 

•*'**««••««**•**••*•*•««******♦«***«*******«**«*«#*****«**««***«**«* 

1829 

177A 

REN 

AMBULATORY  CARE  DATA  BASE  29  JUL  85 

**«• 

1829 

177A 

REM 

•««* 

D  R  BOLLING 

«•«* 

1829 

177A 

REM 

***« 

SUBROUTINE  NAME 

:  RXXS5700.SUB 

1829 

177A 

REM 

SCANNER  PROGRAM  « 

:  ALL 

1829 

177A 

REM 

FUNCTION,. 

:  THIS  SUBROUTINE  MODULE 

1829 

177A 

REM 

CONVERTS  A  BINARY  ARRAY  INTO 

1829 

177A 

REM 

«««* 

TUO  CHAR  COOES. 

•*»* 

1829 

177A 

REM 

*«*• 

**** 

1829 

177A 

REM 

*««* 

INPUT 

:  INP.STOS  AS  STRING 

1829 

177A 

REM 

««•* 

1829 

177A 

REM 

*««• 

•«** 

1829 

177A 

REM 

«*«« 

OUTPUT 

:  BUF.STOt  AS  STRING. 

1829 

177A 

REM 

1829 

177A 

REM 

1829 

177A 

REM 

»*** 

RESERVED  LINE 

1829 

177A 

REM 

*#•* 

NUMBERS 

:  5710-5730 

1829 

177A 

REN 

1829 

177A 

1829 

177A 

8UF.STOS="'’ 

1832 

177A 

N.STO=1 

1839 

177A 

5710 

X.STO=INSTR<N.STO, INP.STOS, 

"I") 

1848 

177A 

IF  X.STO*0  THEN  GOTO  5720 

•THATS  ALL 

185A 

177A 

N.STO  = 

X.STO  ♦  1 

•NEXT  STARTING  POINT 

1862 

177A 

X.STO  * 

X.STO  ♦  100 

•PAD  WITH  LEADING  ZERO 

186C 

177A 

BUF 

.STOS  »  BUF.STOS 

1882 

177a 

IF 

N.STO  <=  LENIINP 

1895 

177A 

1895 

177A 

5720 

RETURN 

1898 

177A 

1898 

177a 

REM  ■ 

. END  OF  ! 

1898 

177A 

5800 

REM  SINCLUOE;  ■RACS58( 

1299 

177A 

REM 

1899 

177a 

REM 

*** 

AMBULATORY  CARE 

1899 

177a 

REM 

«** 

1899 

177A 

REM 

**• 

SUBROUTINE  NAME 

1899 

177A 

REM 

SCANNER  PROGRAM 

1899 

177A 

REM 

«•* 

FUNCTION 

1899 

177A 

REM 

*** 

1899 

177A 

REM 

1299 

177A 

REM 

**« 

1399 

177A 

REM 

**• 

INCLUDE  FOUR  COL  DX  CONVERTER 


30  JUL  85 
D  R  BOLLING 

RXXS5800.SUB 
AS  APPRCV>RIATE 
THIS  SUBROUTINE  MODULE  READS 
FOUR  COLUMNS  IN  DX  AREA  AND 
CONVERTS  TO  A  POSITION  IN  A 
TABLE.  AN  ERROR  CODE  IS 
RETURNED  IF  MULTIPLE  COOES  ARE 


*** 

*** 

*** 

*** 

**• 

**«■ 


RACP830 
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IBM  Personal  Computer  BASIC  Compiler  VI. 00 

1899 

177A 

REM 

•••  PRESENT. 

1899 

177A 

REM 

*«« 

1899 

177A 

REM 

•••  INPUT  ;  X.POS  -  STARTING  POSITION  IN 

*«* 

1899 

177A 

REM 

•••  STRING 

*** 

1899 

177A 

REM 

*«* 

•** 

1899 

177A 

REM 

OUTPUT  :  K.FIN  -  TABLE  POSITION  OF  OX 

1899 

177A 

REM 

•••  RT.5800  »  1  ON  ERROR 

*•* 

1899 

177A 

REM 

**« 

1899 

177A 

REM 

***  RESERVEO  LINE  NUM8ERS  :  5801  -  5899 

*** 

1899 

177A 

REM 

1899 

177A 

RT.5800«0  'INITIALIZE  ERROR  INOICATOR 

18A0 

177A 

X.FIN^O  'INITIALIZE  TABLE  OFFSET  RESULT 

18A7 

177A 

18A7 

177A 

REN  ••  COLUMN  1  •• 

18A7 

177A 

ri*0  'STARTING  POINTER 

18AE 

177A 

X.SIZ^ISIZ 

1885 

177C 

X .  STO»  VAL  (M 1 0$(  TEXTS ,  X .  !>OS ,  2 ) ) 

18CC 

177C 

IF  X.STO*0  THEN  GOTO  5F02 

1808 

177C 

X.FIN=X.STO 

18E2 

177C 

' 

18E2 

177C 

5802  REM  ••  COLUMM  2  *• 

18E3 

177C 

IF  C2StZ*0  THEN  GOTO  5804 

18F2 

177C 

XsXi-X.SIZ 

18F0 

177C 

X.POS=X.POS*2 

1906 

177C 

X.SIZ>C2SI2 

1900 

177C 

X.STC-''AL(MIOS<TEXTS,X.POS,2)) 

1924 

177C 

IF  X.STO<0  THEN  GOTO  5804 

1933 

177C 

IF  X.FIMoO  THEN  GOTO  5890  'ERROR  -  MULTIPLE  CODE 

1942 

177C 

X.FIN=X.STO  ♦  X 

1940 

177C 

1940 

177C 

5804 

REM  *•  COLUMN  3  •* 

194E 

177C 

IF  C3SIZ<0  THEN  GOTO  5806 

1950 

177C 

X:X»X.SIZ 

1968 

177C 

A.P0S*X.P0S*2 

1971 

177C 

X.SI2>C3SIZ 

1978 

177C 

X . ST0= VAL (M I0$< TEXTS , X . PCS , 2) ) 

198F 

177C 

IF  X.STOO  THEN  GOTO  5806 

199E 

177C 

IF  X.FIMoO  THEN  GOTO  5890  'ERROR  -  MULTIPLE  CODE 

19A0 

177C 

X.FIN=X.ST0  ♦  X 

1988 

177C 

1988 

177C 

5806  REM  ••  COLUMM  4  ** 

1989 

177C 

IF  C4SIZ=0  THEN  GOTO  5808 

19C8 

177C 

X=X+X.SIZ 

1903 

177C 

X.P0S=X.P0S+2 

190C 

177C 

X.SIZ=C4SIZ 

19E3 

177C 

X .  ST0=»VAL  (M 1 0S(  TEXTS ,  X .  POS ,  2 ) ) 

19FA 

177C 

IF  X.STO=0  THEM  GOTO  5808 

1A09 

177C 

IF  X.FINoO  THEN  GOTO  5890  'ERROR  -  MULTIPLE  CODE 

1A18 

177C 

X.FIM=X.ST0  ♦  X 

1A23 

177C 

1A23 

177C 

5808  REM 

1A24 

177C 

GOTO  5899 

1A28 

177C 

1A28 

177C 

5890 

RT. 5800=1  'ERROR  -  MULTIPLE  COOES 

KACPSSO 

EMER':eMCY  ROOM  FORM  DESTRlNG/OECOOE  PROGRAM 
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Offset  Data  Source  Line  IBM  Personal  Cwaputer  BASIL  Comiiiler  vi.OO 

1A2F  me 


1A2F 

me 

5899  RETURN 

1A32 

me 

tA32 

177C 

KS.n 

1A32 

177C 

U32 

me 

1A32 

me 

6000  REM  SINCLUOE:  'RACS6000.SUB<  INCLUDE  THE  IHSTRINC  DECODE  SUB 

1A33 

me 

REN 

*3k*%*«*«*«*****'****««*«*«**«**««*«*««  ««**«*«*««•***•*«**«****•***** 

1A33 

177C 

REM 

AMBULATORY  CARE  DATA  BASE  13  APR  85 

1A33 

177C 

REM 

SKIP  COLE 

**•* 

1A33 

177C 

REM 

SUBROUTINE  NAME  :  RXXS6000.SUB 

1A33 

177C 

REM 

***% 

SCANNER  PROGRAM  *  :  ALL 

»«** 

1A33 

177C 

REM 

FUNCTION  ;  THIS  SUBROUTINE  MODULE 

*•«* 

1A33 

177C 

REM 

•««» 

PERFORMS  INSTRING  SEARCH 

U33 

me 

REM 

*«•* 

**** 

U33 

me 

REM 

**** 

INPUT  :  STRING  TO  BE  SEARCHED  MUST 

**** 

1A33 

me 

REM 

BE  IN  THE  VARIABLE  NAMED  : 

***« 

1A33 

me 

REM 

•XS* 

1A33 

me 

REM 

1A33 

me 

REM 

•  «*« 

OUTPUT  :  'TOT'  «  TOTAL  NUMBER  OF 

*•** 

1A33 

me 

REN 

«««« 

HITS  IN  THE  DESTRING 

**•« 

1A33 

me 

REM 

'HOLDSO'  IS  THE  ARRAY 

1A33 

me 

REM 

CONTAINING  THE  NUMERIC 

1A33 

me 

REM 

VALUE  OF  THE  HIT  POSITIONS 

1A33 

me 

REM 

««*« 

1A33 

me 

REM 

***•**«««***««*'*«*««*«•«««**««*'***«**««*•*****«'•*••***•**«*«*«***#* 

1A33 

me 

REH 

RESERVED  LINE 

ft*** 

1A33 

me 

REM 

NUMBERS  :  6001-6009 

1A33 

me 

REM 

******1 

1A33 

me 

6001 

PTR  »  INSTR(X$,"1“) 

1AL1 

177E 

TOT  =  0 

1AA8 

1780 

WHILE 

PTR  »  0 

1A53 

1780 

T0T:*T0T+1 

iA5S 

1780 

HOLDSCTOT)  =  RIGHTt(STRS<PTR),2) 

lATt. 

1780 

PTR=PTR»1 

1A85 

1780 

PTR  =  IHSTK(PTR,XS."1") 

1A97 

1780 

UENO 

1A9B 

1780 

RETURN 

1A9E 

1780 

1A9E 

1780 

1A9E 

1780 

1A9E 

1780 

7000 

REH  SINCLUOE:  ■ R ACS 7000. SUB ■  INCLUDE  THE  SCREEN  HEADER  SUB 

1,19F 

1780 

REM 

***•*•*1 

**««* 

1A9F 

1780 

REM 

**«* 

AMBULATORY  CARE  DATA  BASE  13  APR  85 

*•** 

1A9F 

1780 

REM 

SKIP  COLE 

**** 

1A9F 

1780 

REM 

SUBROUTINE  NAME  :  RACS7000.SUB 

«*** 

1A9F 

1780 

REM 

**«■* 

SCANNER  PROGRAM  #  :  ALL 

»««* 

1A9F 

1780 

REM 

**** 

FUNCTION  :  THIS  SUBROUTINE  MODULE 

««** 

1A9F 

1780 

REM 

**** 

PRINTS  THE  STANDARD  SCREEN 

1A9F 

1780 

REM 

***« 

HEADING. 

***• 

1A9F 

1780 

REH 

•  *** 

INPUT  ;  COMMON  VARIABLE  USER$(2) 

**** 

U9F 

1780 

REM 

SYSTEM  DATE 

"\9F 

1780 

REM 

•  *** 

RACPB30 
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1A9F 

1780 

REM 

OUTPUT  :  SCREEN  HEADING 

**** 

1A9F 

1780 

REM 

IA9F 

1780 

REM 

***• 

RESERVED  LINE 

•*** 

1A9F 

1780 

REM 

NUMBERS  :  7001-7010 

**** 

1A9F 

1780 

REN 

1A9F 

1780 

1A9F 

1780 

7001 

LOCATE 

1.1 

1AA9 

1780 

PRINT  "U.S.  ARMY  AMBULATORY  CARE  INFORMATION  SYSTEM" 

1A81 

1780 

LOCATE 

1,65 

USE 

1780 

PRINT  DATES; 

1AC6 

1780 

LOCATE 

2,1 

1A03 

1780 

PRINT  "USER  :  ";USER$<1) 

1AE0 

1780 

RETURN 

1AE3 

1780 

1AE3 

1780 

7100  REM  SINCLLDE:  'RACS7100.SUB ■  INCLUDE  THE  PRINTER  HEADER  SUB 

IAEA 

1780 

REM 

IAEA 

1780 

REM 

AMBULATORY  CARE  DATA  BASE  13  APR  85 

IAEA 

1780 

REM 

»*** 

SKIP  COLE 

**** 

IAEA 

1780 

REM 

SUBROUTINE  NAME  :  RXXS7100.SU8 

IAEA 

1780 

REM 

SCANNER  PROGRAM  «  :  ALL 

IAEA 

1780 

REM 

FUNCTION  :  THIS  SUBROUTINE  MODULE 

•«** 

IAEA 

1780 

REM 

PRINTS  THE  STAIOARD  HEADING 

**** 

IAEA 

1780 

REM 

•««« 

ON  THE  PRINTER. 

IAEA 

1780 

REM 

INPUT  :  DATE, PAGE. PGMIDS.PGMTITLS 

IAEA 

1780 

REM 

IAEA 

1780 

REM 

OUTPUT  :  PRINTER  HEADING,  LN. COUNT 

**•« 

IAEA 

1780 

REM 

•**« 

IAEA 

1780 

REM 

RESERVED  LINE 

IAEA 

1780 

REM 

NUMBERS  :  7101-7110 

IAEA 

1780 

REM 

IAEA 

1780 

IAEA 

1780 

7101 

IF  PAGE  >  0  THEN  LPRIHT  CHR$(12); 

1AFA 

1780 

LPRINT 

"ARMY  AMBULATORY  CARE  INFORMATION  SYSTEM _  ";PGMTITLS; 

1B07 

178A 

LPRINT 

TAB<70), -OATES 

181A 

178A 

PAGE=PAGE+1 

1B22 

178A 

LPRINT 

"PROGRAM  ";PGMI0$;TAB<70);"PAGE"; 

1B3F 

178A 

LPRINT 

USING  "#«W«";PAGE 

1BAB 

178A 

LPRINT 

1BS3 

178A 

LN.C00NT=3 

1BSA 

178A 

RETURN 

1B5D 

178A 

1BSO 

178A 

8000  REM  $ INCLUDE:  'RACSBOOO.SUB'  INCLUDE  THE  DECODE  SUB  GROUP 

18SE 

178A 

REM 

IBSE 

178A 

REN 

***• 

AMBULATORY  CARE  DATA  BASE  13  APR  85 

*•* 

185E 

178A 

REM 

**** 

SKIP  COLE 

*•*  r' 

1B5E 

178A 

REM 

***• 

SUBROUTINE  NAME  :  RXXS8000.$U8 

185E 

178A 

REM 

***• 

SCANNER  PROGRAM  #  :  ALL 

ft** 

185E 

178A 

REM 

FUNCTION  :  THIS  SUBROUTINE  MODULE 

ft** 

IBSE 

178A 

REM 

IS  A  GROUPING  THAT  PERFORMS 

ft** 

1B5E 

178A 

REM 

*«•** 

VARIOUS  OECOOING  FUNCTIONS 

*«* 

1B5E 

178A 

REM 

ON  THE  SCANNER  DATA 

ft** 

1B5E 

178A 

REM 

•  ••* 

*** 

1B5E 

178A 

REM 

8001  -  DECODE  THE  HEADER  POSITIONS  (POINTER  0-20) 

*** 

185E 

178A 

REM 

«*** 

8050  -  CHECK  FOR  END  OF  JOB 

*** 

RACPaso 
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1B5E 

1784 

REM 

8100  -  PRINT  THE  HEADER  DATA  ON  THE  SCREEN 

1B5E 

1784 

REM 

8200  -  DECODE  THE  RESPONSE  POSITIONS  (POINTER 

1BSE 

1784 

REM 

(RETURNED  IN  TEXTS  STRING  VARIABLE) 

1BSE 

1784 

REM 

*«*« 

1BSE 

1784 

REM 

**•*  INPUT  ;  SHEET  RECORD,  RECORD  LENGTH 

1BSE 

1784 

REM 

**** 

185E 

1784 

REM 

*»**  OUTPUT  :  'TEXTS*  TRING  VARIABLE 

1BSE 

1784 

REM 

**** 

1BSE 

1784 

REM 

*•••  RESERVED  LINE 

1BSE 

1784 

REM 

*•••  NUMBERS  :  8001-8500 

'•35E 

1784 

REM 

•**«*‘**«***«*«*«««**«««***«*****«*«*****«««*****«****«**« 

1B5E 

1784 

1BSE 

1784 

■DECOOE  THE  HEADER  ONLY 

1BSE 

1784 

8001 

POINTER  «  0 

1B6S 

1786 

RECORDPTR  >  VARPTR(SHEETREC(0)) 

1B6C 

1788 

FOR  J8000  =  1  TO  21 

1873 

1788 

8002 

TEXTS*  TEXTS+CHRS(PEEX(RECOROPTR  ♦  POINTER)) 

1891 

1788 

POINTER*POINTER+1 

1899 

1738 

NEXT  jeooo 

18Aa 

178A 

PROGRAMS*  LEFTS(TEXTS,3) 

1887 

178E 

BATCHS*  MI0S(TEXT$,4,3) 

18C9 

1792 

SERIALS*  MI0S(TEXT$,7,4) 

1B08 

1796 

RUNJDS*  M10$(TEXTS,11,1) 

IBED 

179A 

FORMS*  M I 0$< TEXTS, 12,2) 

1BFF 

179E 

POCKETS*  MI0S(TEXTS,14,1) 

1C11 

17A2 

SCANERR1S=MI0S(TEXTS,16,2) 

1C23 

17A6 

SCANERR2$*MI0S(TEXTS,18,2) 

1C35 

17AA 

SCANERR3S=M 1 0$( TEXTS,  20 , 2 ) 

1C47 

17AE 

GOTO  8500 

1C4B 

17AE 

1C4B 

17AE 

8050 

REM  CHECK  FOR  END  OF  JOS/END  OF  BATCH 

1C4C 

17AE 

IF  PROGRAMS  *  PGM I OS  THEN  GOTO  8500 

*C5E 

17AE 

LPRINT  STRJNGS(80,"*") 

1C6C 

17AE 

LPRIHT 

1C74 

17AE 

LPRINT  "RECORDS  PROCESSED  ...  "iSERIALS 

1C81 

17AE 

LPRINT  "STARTED  AT  .  «;BT1ME$ 

ICSE 

17AE 

LPRINT  "ENDED  AT  .  ";TIMES 

1C9B 

17AE 

LPRINT  CHR$(12) 

1CA6 

17AE 

GOTO  30000 

1CAA 

17AE 

1CAA 

17AE 

8070 

REM  CHECK  FOR  SCANNER  ERRORS 

1CAB 

17AE 

IF  POCKETS  *  "  "  GOTO  8500 

l.’BO 

17AE 

LPRINT  LITHOS; 

1CC5 

17AE 

LPRINT  »  ...  SCANNER  ERRORS  : 

1CCO 

17AE 

LPRINT  SCANERR1S;"  / 

1COA 

17AE 

LPRINT  SCANERR2$;"  /  "; 

1CE7 

17AE 

LPRINT  SCANERR3S 

1CEF 

17AE 

LN=LN+1 

'Cf7 

1780 

GOTO  999 

ICIB 

1780 

ICFB 

1780 

8100 

REM  PRINT  THE  HEADER  VARIABLES  ON  THE  TUBE.... 

ICfC 

1780 

LOCATE  5,1:PRINT  "PROGRAM  ";PROGRAHS; 

1"I6 

1780 

1016 

1780 

PRINT  "  BATCH  ".-BATCHS; 
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1D23 

17B0 

1030 

17B0 

1D30 

17B0 

104A 

17B0 

1D4E 

17B0 

1D4E 

17B0 

8200 

1D4F 

17B0 

1056 

17B0 

1050 

17B0 

1D6A 

17B2 

8202 

1D88 

17B2 

1090 

17B2 

10A1 

17B2 

1DA1 

17B2 

8500 

1DA4 

17B2 

10A4 

17B2 

1DA4 

17B2 

1DA4 

17B2 

9000 

10A5 

17B2 

REM 

10A5 

17B2 

REM 

10A5 

17B2 

REM 

10A5 

1782 

REM 

1DA5 

17B2 

REM 

1DA5 

17B2 

REM 

IDAS 

17B2 

REM 

10A5 

1782 

REM 

10A5 

17B2 

REN 

10A5 

17B2 

REM 

1DA5 

17B2 

REM 

1DA5 

17B2 

REN 

10A5 

17B2 

REM 

1DA5 

17B2 

REM 

1DA5 

17B2 

REM 

1DA5 

1732 

RE** 

10A5 

17B2 

10A5 

1782 

10A5 

17B2 

REM 

10A5 

17B2 

REM 

10A5 

17B2 

REM 

IDAS 

17B2 

REM 

IDAS 

1782 

9001 

10A6 

17B2 

10A0 

17B2 

1084 

17B2 

loss 

17B2 

10C2 

17B2 

1DC9 

17B2 

IDDO 

1782 

1007 

17B2 

1007 

17B2 

10E3 

17B2 

IDEA 

17B4 

1DFB 

17B4 

1E04 

17B4 

PRINT  x  RUN  ":RUNI0S; 
PRINT  X  FORM  FORMS; 
PRINT  X  POCKET  xjpOCKETS 


GOTO  8500 


POINTER  -  21 

RECOROPTR  •  VARPTR(SNEETREC(0)} 

FOR  jaOQO  >  22  TO  RECOROLENGTH 

TEXTS  =  TEXTS*CHRS(PEEK(RECORDPTR  ♦  POINTER)) 
POINTER=POINTER*1 
NEXT  J8000 


END  OF  RXXS8000.SUB 


REM  SINCLUOE:  ■ RACS9000 . SUB •  INCLUOE  THE  SCANNER  CONTROL  SUB 

M***************************************************************** 


AMBULATORY  CARE  DATA  BASE 


PROGRAM  NAME 
SCANNER  PROGRAM  # 
FUNCTION 


13  APR  85 
SKIP  COLE 

RACS9000.SU8 

ALL 

THIS  SUBROUTINE  MODULE 
CONTROLS  THE  SCANNER  I/O 


INPUT/OUTPUT  :  REFER  TO  THE  ASYNCHRONOUS  ***» 

COMMUNICATIONS  MANUAL  AND  THE 

•••*  PRE- RELEASED  SOFTWARE  GUIDE 

•••• 

•**«********«*************«**«*********«*************************** 

RESERVED  LINE  •*** 

NUMBERS  :  9001-9100  **•* 


••••  SUBROUTINE  9001  •  PROTOCOL  SETUP  FOR  SCANNER 
••••  ARGUMENTS:  PRESET  ...  SEE  BELOW 


PROTOCOL(O)  =  9600 
PROTOCOL(I)  =  78 
PROTOCOL(2)  =  8 
PROTOCOL(3)  =  1 
PROTOCOL (4)  =  2 
PROTOCOL(5)  =  0 
PR0T0C0L(6)  =  0 


•BAUD  RATE 

•PARITY  (SEE  PAGE  4-8  OF  MANUAL) 

■DATA  BITS 

•STOP  BITS 

•RS-232  PORT 

•WRITE  TIME-OUT 

■READ  TIME-OUT 


ERRSTATS  =  SPACES(60) 

ARGPTR  »  VARPTR(PROTOCOL<0)) 

CALL  SETUP  (ARGPTR, ERRSTATS) 

ERRMSGS="" 

IF  ASC(ERRSTATS)  <>  64  THEN  ERRMSGS=»SETUP  ERROR  "tERRSTATS 
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1E20 

17B4 

GOTO  9100 

1E24 

17B4 

1E24 

17B4 

REM 

1E24 

17B4 

REM 

SUBROUTINE  9010  -  CONTROL  OPTIONS  FOR  SCANNER 

1E24 

17B4 

REM 

••••  ARGUMENTS:  CNTRLOPT 

1E24 

17B4 

REM 

CNTRLOPT  «  1  =  START  SCANNER  {SI) 

1E24 

17B4 

REM 

••••  CNTRLOPT  =  2  =  STOP  SCANNER  (SO) 

1E24 

17B4 

REM 

**•*  CNTRLOPT  •  3  »  TERMINATE  COMMUNICATIONS  TO  SCANNER  (DC3) 

1E24 

17B4 

REM 

••••  CNTRLOPT  =  4  »  CLEAR  TRANSPORT  PATH  (DC2) 

***** 

1E24 

17B4 

REM 

CNTRLOPT  =  5  *  SELECT  PRIMARY  STACKER  "31“ 

1E24 

17B4 

REM 

CNTRLOPT  =  6  =  SELECT  SECONOARY  STACKER  "32" 

1E24 

17B4 

REM 

••••  CNTRLOPT  •  7  =  POSITIVE  RESPONSE/SELECT  SCANNER  (DC1) 

1E24 

17B4 

REM 

CNTRLOPT  *  8  =  REQUEST  STATUS  (ESC) 

1E24 

17B4 

REM 

1E24 

17B4 

9010 

REM 

1E25 

17B4 

ERRSTATS  ^  SPACES(60) 

1E31 

17B4 

CALL  CNTROL  (CNTRLOPT, ERRSTATS) 

1E42 

17B4 

ERRMSG$="" 

1E4B 

17B4 

IF  ASC(ERRSTATt)  <>  64  THEN  ERRMSG$=“CONTROL  ERROR  “♦ERRSTATS 

1E67 

17B4 

GOTO  9100 

1E6B 

1784 

1E6B 

1784 

REM 

»***•* 

1E6B 

1784 

REM 

SUBROUTINE  9020  •  SCAN  SHEET  CALL 

**»•• 

1E6B 

1784 

REM 

***** 

1E6B 

1784 

REM 

**•*  ARGUMENTS:  READTYPE 

1E68 

1784 

REM 

**•*  READTYPE  =  2  *  REQUEST  NEW  DOCUMENT  FROM  SCANNER 

***** 

1E6B 

1784 

REM 

»«..  READTYPE  =  3  =  RETRANSMIT  CURRENT  DOCUMENT 

***** 

1E63 

1784 

REM 

«*•* 

1E6B 

1784 

REM 

ARGUMENTS:  RECORDLENGTH 

***** 

1E6B 

1784 

REM 

»»*•  NUMERIC  VARIABLE  SET  TO  THE  NUMBER  OF  CHARACTERS  TO  BE 

1E6B 

1784 

REM 

****  TRANSMITTED 

1E6E 

1784 

REH 

1E63 

1784 

9020 

REH 

1E5C 

1784 

ERRSTATS  =  SPACEt{60) 

1E78 

17B4 

RECOROPTR  =  VARPTR(SKEETR£C(0)) 

‘E7F 

17B4 

CALL  SCAN  (READTYPE, RECORDLENGTH, RECORDPTR, ERRSTATS) 

1E98 

1784 

ERRMSGS="" 

1EA1 

1784 

IF  MIDS(ERRSTATS,14,3)  =  "415"  THEN  ERRMSGS="ESC" 

1EC2 

1784 

GOTO  9100 

1506 

1734 

1EC6 

17B4 

REH 

1EC6 

1784 

REH 

•»**  SUBROUTINE  9030  -  TRANSPORT  PRINT  CALL 

1Ei:6 

1784 

REM 

«•** 

iEC6 

1784 

REH 

***•  ARGUMENTS:  PRINTPOS 

1EC6 

1784 

REM 

*•♦*  NUMERIC  VARIABLE  INDICATING  THE  STARTING  PRINT  POSITION 

rc6 

1784 

REM 

VALUES  =  0  THRU  90 

iec6 

1784 

REM 

**** 

1EC6 

1784 

REH 

ARGUMENTS:  PSTRINGS 

1EC6 

1784 

RFH 

*»*•  TEXT  TO  BE  PRINTED  ON  THE  FORM 

1EC6 

17B4 

REM 

**** 

1EC6 

1784 

REH 

****  NOTE:  THIS  ROUTINE  HAS  NO  EFFECT  UNLESS  THE  SCAN 

•£C6 

1EC6 

1784 

1784 

REM 

REH 

*•**  HEADER  SHEET  IS  MARKED  'PRINTER  ON* 

***** 

RACP830 
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Offset 

Data 

Source  Line 

1EC7 

17B4 

ERRSTATS  =  SPACE$(60) 

1E03 

17B4 

RECORDPTR  =  VARPTRfSHEETRECfO)) 

1EDA 

17B4 

CALL  TPR1NT{PRIMTP0S,PSTRIMG$,ERRSTAT$) 

1EEF 

17BA 

IF  ASCIERRSTATS)  <>  64  THEN  ERRMSG$=“PRINT  ERROR  “+ERRSTAT* 

1F0B 

17BA 

GOTO  9100 

1F0F 

17BA 

1F0F 

17BA 

9100 

RETURN 

1F12 

17BA 

1F12 

17BA 

1F12 

17BA 

REM  I 

1F12 

17BA 

1f12 

17BA 

25000 

REM  USER  TERMINATED  INPUT...  FILE  IS  NOT  TO  BE  USEDMII 

1F13 

17BA 

LPRINT  "USER  TERMINATED  INPUT  ..  DATA  WILL  NOT  BE  USEDI" 

1F1B 

17BA 

LPRINT  "ERASING  FILE  ";DATFIL$ 

1F28 

17BA 

BEEP 

1F2C 

17BA 

CLS  :  PRINT  "USER  TERMINATED  INPUT  ..  DATA  WILL  NOT  BE  USED!" 

1F38 

17BA 

CLOSE 

1F3C 

17BA 

OPEN  DATFILS  FOR  OUTPUT  AS  #1 

1F4E 

17BA 

PRINT  #1,STRING$<RECOROLEMGTH,“X")  'VOID  THE  FIRST  RECORD 

1F60 

17BA 

CLOSE 

1F64 

17BA 

1F64 

17BA 

30000 

REM 

1F65 

17BA 

CLOSE 

1F69 

17BA 

CHAIN  "RACP10" 

1F70 

17BA 

1F73 

178A 

22151  Bytes  Available 

15513  Bytes  Free 
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0  Severe  Error(s) 
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001A 

0002 

REN 

$L I RESIZE:  132 

001A 

0002 

REM 

SPAGESIZE:  66 

001A 

0002 

REM 

STITLE:  'RACP850  • 

001A 

0002 

REM 

SSUBTITLE:  'GROUP  FORM  I  &  11  OESTRING/DECOOE  PROGRAM 

001A 

0002 

REM 

SPAGE 

I* 


RACP8S0 

GROUP  FORM  I  &  II  DESTRIHG/DECOOE  PROGRAM 


Offset 

Data 

001A 

0002 

001A 

0002 

001A 

0002 

001A 

0002 

001A 

0002 

001A 

0002 

001A 

0002 

001A 

0002 

001A 

0002 

001A 

0002 

001A 

0002 

001A 

0002 

001 A 

0002 

001A 

0002 

001A 

0002 

001A 

0002 

001A 

0002 

001A 

0002 

001A 

0002 

001 A 

0002 

001 A 

0002 

001A 

0002 

001A 

0002 

001A 

0002 

001A 

0002 

001A 

0002 

001A 

0002 

001A 

0002 

001A 

0002 

001A 

0002 

001A 

0002 

001A 

0002 

001 A 

0002 

001A 

0002 

001A 

0002 

001A 

0002 

001A 

0002 

001A 

0002 

001A 

0002 

001A 

0002 

001A 

0002 

001A 

0002 

OOIA 

0002 

001 A 

0002 

OOIA 

0002 

OOIA 

0002 

001A 

0002 

OOIA 

0002 

001A 

0002 

OOIA 

0002 

OOIA 

0002 

OOIA 

0002 

001A 

0002 

OOIA 

0002 
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REM  . . . 

REM  I  NAME:  RACP850  AMBULATORY  CARE  INFORMATION  SYSTEM  | 
REM  I  DATE:  10  JUN  87  GROUP  FORM  I  t  II  PROGRAM  | 
REM  I  0  R  BOLLING  | 
REM  . . . 


REM  GROUP  FORM  I  <  II  OMR  INPUT  PROGRAM 

REM 

REM  This  program  reads  the  base  form  OMR  data,  converts  various 
REM  fields,  prints  an  error  report  and  produces  the  file: 

REM 

REM  VISIT.OAT 

REM 

REM  for  input  to  FOCUS.  NOTE  THAT  THIS  FILE  IS  OPENED  FOR  APPEND 
REM  each  time  the  program  is  run.  Thus,  if  the  file  does  not  exist, 

REM  records  Mill  be  added  to  the  front.  If  the  file  exists,  records 
REM  will  be  added  to  the  end  of  the  current  file.  It  is  intended  that 
REM  the  FOCUS  DIALOGUE  MANAGER  ROUTINE  which  loads  the  data  will  delete 
REM  the  data  file  after  the  load  has  been  successfully  accomplished. 

REM 

REM  If  there  is  no  valid  user  logged  at  the  time  of  execution,  this 
REM  program  will  chain  to  the  logon  program  RACPOS,  otherwise, 

REM  the  program  chains  to  program  RACP10  on  exit. 

REM  SINCLUDE:  'RACOIM.MOO'  REM  INCLUDE  THE  DIMENSION  DEFINITIONS 


NAME:  RACOIM.MOO  DIMENSION  DEFINITIONS 

Date:  28  Feb  84  Written  by:  Floyd  Cole 


Dimensioned  variables  are  defined  in  this  file. 

It  is  an  included  file  so  it  cannot  be  run  in  a  stand-alone, 
mode. 

This  program  segment  may  be  modified,  but  all  files  containing 
an  include  for  this  segment  must  be  re-compiled  in  order  to 
affect  the  changes  made  here. 

••••*•••••*•  START  OF  DIMENSION  DEFINITION  ••«»•*•••«*••••••*•' 


DEFINT  A-Z 

DIM  USERS(2),MOLENGTH(12),DATEERR$<3) 
•••**•••**•*  END  OF  DIMENSION  DEFINITIONS 


REM  DIMENSION  STATEMENTS  UNIQUE  TO  THIS  PROGRAM 


DIM  SHEETRECCITSO) 
DIM  PROTOCOL(7) 

DIM  YN$(3) 

DIM  ED.HSGS(30> 

DIM  CLINICI.PFXS(S) 
DIM  CLINIC2.PFXS(6) 
DIN  PROCEDt(098) 

DIM  HOLD$(99) 

DIM  SPECLS<09) 


'(MAX.  SIZE  FOR  A  SHEET  FROM  THE  SCANNER) 
'(ARRAY  FOR  SERIAL  BOARD  SETUP  PARAMETERS) 
'(YES/NO  ANSWERS  0=7,  1  =  Y  ,  2=N  ,  3=X) 
'(ERROR  MESSAGES  FROM  EDIT  ROUTINES) 
'(PREFIX  -B  D  F  G  S-  FOR  CLINIC  #1) 

'(PREFIX  -A  B  C  D  F  S-  FOR  CLINIC  #2) 
'(PROCEDURE  TABLE  FOR  BASE  FORM) 

•(HOLD  AREA  FOR  SUBROUTINE  6000) 

'(SPECIAL  PROGRAMS) 


RACP850 

CROUP  FORM  I  t  II  DESTRING/DECOOE  PROGRAM 


Offset  Data  Source  Line 


001A 

001A 

001A 

001A 

001A 

001A 

001A 

001A 

001A 

001A 

OOIA 

001A 

001A 

OOIA 

OOU 

OOIA 

OOIA 

OOIA 

OOIA 

001A 

OOU 

OOU 

OOU 

OOU 

OOU 


0002 

0002 

0002 

0002 

0002 

0002 

0002 

0002 

0002 

0002 

0002 

0002 

0002 

0002 

0002 

0002 

0002 

0002 

0002 

0002 

0002 

0002 

0002 

0002 

0002 
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REN  SINCLUOE:  'RACCMN.MOO'  REM  INCLUDE  THE  COMMON  AREA  DEFINITION 

a********************************************************************* 


COMMON  AREA  DEFINITION 
Written  by:  Floyd  Cole 


•  NAME:  RACCMN.MOO 

•  Date:  28  Feb  84 

********************************************************************** 

COMMON  AREA  DEFINITIONS  WILL  BE  HELD  IN  THIS  FILE.  IT  IS  AN 
INCLUDED  FILE  SO  IT  CANNOT  BE  RUN  IN  A  STANOULONE,  NODE. 

This  program  segment  may  be  modified,  but  all  files  containing 
an  include  for  this  segment  must  be  re*compiled  in  order  to 
affect  the  changes  made  here. 


•START  OF  COMMON  DEFINITIONS**** 


COMMON  FORE, BACK, BOARD, HIDE, EFORE.EBACIC, BELLS  'BASIC  SCREEN  COLORS 


COMMON  HEADERS 
COmON  TEXTS 
COMMON  PGMIOS 
COMMON  MOLENGTHO 
COMMON  USERSO 

*************EN0  OF  COMMON  06f IHITION************************* 


•21  CHARACTER  SCANNER  HEADER  INFO 
"  AINING  CHARACTERS  FROM  SCANNER 
•PROGRAM  OR  FORM  ID 
•DATS  IN  THE  MONTH 


REM  SINCLUDE:  'RACOEF.MOO' 


REM  INCLUDE  THE  DEFAULT  DEFINITIONS 


OOU 

0002 

1** 

«**«•«««****«*•«*«««•***•**«**«'**•*■**•****««******* 

OOU 

0002 

1* 

NAME:  RACP01.0EF  DEFAULT  DEFINITIONS 

OOU 

0002 

l« 

Date;  28 

Feb  84  Written  by;  Floyd  Cole 

OOU 

0002 

OOU 

0002 

Variables 

used 

in  common  that  have  a  default  value  on  start*up 

OOIA 

0002 

will  be  held  in  this  file.  It  is  an  included  file  so  it  cannot 

OOU 

0002 

be  run  in 

a  stsnd*alone  mode.  In  normal  operation,  this  file 

OOU 

0002 

should  be 

•included'  in  the  main  program  only  (RACPIO.BAS). 

OOU 

0002 

OOU 

0002 

This  program  segment  may  be  modified,  but  all  files  containing 

OOU 

0002 

an  include 

for 

this  segment  must  be  re*compiled  in  order  to 

OOU 

0002 

affect  the  changes  made  here. 

OOU 

0002 

OOU 

0002 

OOU 

0002 

•••START  OF  DEFAUIT  DEFINITION************************ 

OOU 

0002 

FORE  =  15 

•FOREGROUND  COLOR  =  INTENSE  WHITE 

0046 

1104 

BACK  =  1 

•Background  Color  =  Light  Blue 

004D 

1104 

BORO  4 

•BORDER  c  RED 

0054 

1106 

HIOE  >  4 

•ALTERNATE  COLOR  <  RED 

0058 

1106 

EFORE=  14 

•ERROR  FOREGROUND  DISPLAY 

0062 

1106 

EBACK=  0 

•ERROR  BACKGROUND  DISPLAY 

0069 

1106 

BELLS  =  CHRS<7) 

•Sound  the  bel 1 

1075 

1106 

0075 

1106 

HOLENGTHd) 

S 

31  'JAN 

007C 

1106 

MOLENGTH(2) 

3 

28  'FEB  <--MOOIFIEO  IN  SUBROUTINE  RACS5000. 

0083 

1106 

MOLENGTH(3) 

= 

31  'MAR 

003A 

1106 

MOLENGTH(4) 

= 

30  'APR 

0091 

1106 

MOLENG^  :<5) 

31  'MAY 

0098 

1106 

MOLEMGrH(6) 

30  'JUN 

RACP8S0 

l»OUP  FORM  I  &  tl  DESTRING/OECOOE  PROGRAM 


1 


Offset 

Data 

009F 

11D6 

OOA6 

1106 

OOAD 

1106 

00B4 

11D6 

OOBB 

11D6 

OOC2 

1106 

OOC9 

11D6 

OOC9 

1106 

0002 

1106 

OOOB 

1106 

00E4 

1106 

OOEO 

1106 

OOEO 

1106 

OOF4 

1108 

OOFD 

HOC 

OOFO 

HOC 

OOFD 

HOC 

OOFD 

HOC 

OOFD 

HOC 

0103 

HOC 

0103 

HOC 

0103 

HOC 

0103 

HOC 

0103 

HOC 

0103 

HOC 

0115 

HOC 

0127 

HOC 

0139 

HOC 

014B 

HOC 

015D 

HOC 

016F 

HOC 

0178 

HOC 

0178 

HOC 

0178 

HOC 

0178 

HOC 

0193 

HOC 

01AE 

HOC 

01 C9 

HOC 

01E4 

HOC 

01FF 

HOC 

021A 

HOC 

0235 

HOC 

0250 

HOC 

026B 

HOC 

0286 

HOC 

02A1 

HOC 

02BC 

HOC 

0207 

HOC 

02F2 

HOC 

0300 

HOC 

0328 

HOC 

0343 

HOC 

035E 

HOC 

0379 

HOC 

Source  Line 

H0LENGTH(7> 

S 

31 

■JUL 

M0LENGTH(8> 

= 

31 

■AUG 

M0LENGTH(9> 

M 

30 

•SEP 

MOLENGTH(IO) 

= 

31 

•OCT 

MaENGTH(H> 

9 

30 

•NOV 

M0LENGTH(12> 

m 

31 

•DEC 

DATEERRS(0> 

u 

M  M 

DATEERRSd) 

a 

■INVALID 

MONTH" 

DATEERRS(2> 

a 

"INVALID  DAY  " 

0ATEERR$<3> 

a 

"OAY  TOO 

URGE  FOR  MONTH  COOED" 

MAXLENGTH 

a 

80 

•MAXIMUM  LENGTH  OF  OUTPUT  RECORD 

PADS 

a 

M  M 

•PAD  CHARACTER  FOR  SHORT  RECORDS 

'END  OF  DEFAULT  DEFINtTIOH»»**»»*»»***»*»' 


KEY  OFF 


REM 


REM  **•  ENCOUNTER  FORM  CLINIC  PREFIX  TABLE 


REM  CLINIC  «1 

CLINIC1.PFX$<0)s»  " 
CLINIC1.PFX$(1)*"B" 
CLINIC1.PFX$<2)="D“ 
CLINIC1.PFX$(3)*"F” 
CLINIC1.PFXS(4)*”G<< 
CLINIC1.PFX$(5)="S'' 


CLINIC  »2 

:  CLINIC2.PFX»(0)»"  " 
;  CLINIC2.PFX»(1)»"A" 
:  CLINIC2.PFX$<2)=“B’’ 
:  CLIN|C2.PFX$(3)="C" 
:  CLINIC2.PFX$(«)="0" 
:  CLINIC2.PFX*(5)=:"F» 
CLINIC2.PFX$(6)="S" 


REM 

REM  PROCEDURE  TABLE 

PROCEDS(00)x''  «  ;  PROCE0$(33)«"07127"  ;  PROCEDS(66)::'’0605S'< 
PROCED*(01)*"02008"  :  PROCED$<3«)s"07l28"  :  PROCEOt{67)="03101" 
PROCED$(02)*"02015"  :  PROCE0$(35)="02600''  ;  PROCEDS(68):''04240" 

PROCED$( 03 >="02080"  ;  PROCED$(36)="07129"  :  PROCED»(69)="04128" 

PROCED$(04) ="02081"  :  PROCE0$(37)="07130"  ;  PROCEO*{ 70) ="04241" 

PROCEO$( 05 >*"02082"  :  PROCED$<38>="07131"  :  PROCED»(71 >="04242" 

PROCED^(06>="07100"  :  PROCE0$(39>="02596“  :  PROCE0*(7Z>="04137" 

PROCE0$<07>="07101"  :  PROCED$<40>="02S97"  :  PROCED*(73>="04126" 

PROCED$(08>="07102"  :  PROCED${41 >="02598"  :  PROCED*(74)="06054" 

PROCED*(09>="07103"  :  PROCED$(42> ="02599"  :  PROCEO»( 75 >="06088" 

PROCE0$<10>="07104"  ;  PROCEDS(43>="02600"  :  PROCED*(76>="06052" 

PROCEDSL 11 >="07105"  :  PROCED$(44 >="02601"  :  PROCE0t(77>="06056" 

PROCEO$(12>="07106"  :  PROCEOS(45 >="02100"  :  PROCE0*(78>="06089" 

PROCEOt(13>="07107"  :  PROCEOS(46>="02101"  :  PROCEOt{79>="06057" 

PROCEDt<14)="07108"  :  PROCED$(47>="02102"  :  PROCEDt(80>="06090" 

PROCEO*(15>="07109"  :  PROCEDt(48>="02l03"  :  PR0CED$(81 >="06035" 

PROCE0$(16>=«07110"  :  PROCED$(49>="02104”  :  PROCEO*{82>="06055" 

PROCEDt(17>="07111"  :  PROCED$< 50 >="02600"  :  PROCEDS(83>="06079" 

PROCED1<18>="07112"  :  PR0CE0S(51 >="03050"  :  PROCEDt<84>="02590" 

PROCED$(19>="07113"  :  PROCED*(52>="03051”  :  PROCED$(85 >="02591" 


PAGE  4 
07  06-87 
14:47:41 

IBM  Personal  Ccwijuter  SASIC  ConpiUr  vl.OO 


RACP850 

CliOUP  FORM  I  t  II  OESTRING/OECOOE  PROGRAM 


Offset 

Oats 

Source  Lfne 

0394 

HOC 

PROCE0$(20)»"07H4"  ; 

PROCED$(S3)>"03052"  ; 

PROCEOS(86)*"06056" 

03AF 

HOC 

PROCEDS(21)s«07H5"  ; 

PROCEDt(S4)>"030S3"  : 

PROCE0S(87)*“02592« 

03CA 

HOC 

PROCED$(22)«“07H6“  : 

PROCE0S(55)*“03054"  ; 

PR0CEDS(88)*"02S93" 

03E5 

HOC 

PR0CED$(23)««07H7«  : 

PROCE0S(56)*"030S5"  : 

PR0CEDS(89)«"04137“ 

0400 

HOC 

PROC£DS(24}=*07H8»  : 

PROCEDS(57)«*03056"  : 

PROCE0S(9O)»"02S94" 

0418 

HOC 

PROCED$<25)="07H9«  ; 

PR0C£0$(58)»"03057"  ; 

PR0CE0S(91 )»"02450" 

0436 

HOC 

PR0CE0S(26)>>07120‘*  : 

PROCEDS(S9)*"0305a>  : 

PR0CEDS(92)=“02455" 

0451 

HOC 

PR0CE0$(27)=«07121"  : 

PROCE0S<60)«"03059»  : 

PROCEDS(93> *"02456" 

046C 

HOC 

PROC£OS(28)»"07122"  : 

PROC£0$<61)=“03060"  : 

PROCEOi(94)*"02457" 

0487 

HOC 

PROCEO$(29)=“07123"  : 

PROCE0$(62)*"03061"  : 

PROCED$<95 >*“04137" 

04A2 

HOC 

PROCE0$(30)=«07124"  : 

PROCE0S(63)=“03062“  ; 

PROCED$(96>=“02458" 

0480 

HOC 

PROCE0${31)=“07125“  ; 

PROCEO$(64)>"03063"  : 

PROCED$(97)r“02459" 

0408 

HOC 

PROCE0S(32)=“07126"  : 

PROCE0S(65)*«O310O"  : 

PR0CED$(98)»"90768“ 

04F3 

HOC 

04F3 

HOC 

REM 

««•*•**««****«**************«**«•**««**«*«••**«««*«*•**•****♦*« 

04F3 

HOC 

REM 

TES/Nu  FABLE 

04F3 

HOC 

YM$(0)»“  «  ;  YM$<1)»"r«  ;  YM$<2)*«N" 

:  YNt(3)«"X" 

0517 

HOC 

0517 

HOC 

0517 

HOC 

REH 

«*««*«*«**«*«*««*****••«**««**•«*«***«*«***«***«•••**•*«•••«*«« 

0517 

HOC 

PNUH=VAL<PGMIO$)/10 

0529 

HOE 

REM 

LENGTH  OF  STRING  RECEIVEO  FROM  THE  OMR _ 

0529 

HOE 

HEADER  a  21 

0530 

HEO 

RESPONSE*  173 

0537 

HE2 

RECOROLENGTH  *  HEAOER  *  RESPONSE 

0542 

HE4 

0542 

HE4 

N.PROC  *  98 

■  NUMBER  OF  PROCEDURES  FOR  THIS  FORM 

0549 

HE6 

0549 

HE6 

OATFILS  «  "VISIT. OAT"  'FILE  TO  BE  INPUT  TO  FOCUS 

0552 

HEA 

BTIME$*TIME$ 

'SCAN  START  TIME 

0558 

HEE 

0558 

HEE 

REM 

ENCOUNTER  FORM 

PROCEDURE  TABLE 

0558 

HEE 

0558 

HEE 

REM 

INCLUOE:  'UCACAMP.OPT 

'  INCLUOE  THE  OUTP  UCA  VALIDATE  TABLE 

0558 

HEE 

REM 

INCLUOE:  'UCACAMP.IPT 

'  INCLUOE  THE  INP  UCA  VALIDATE  TABLE 

0558 

HEE 

0558 

HEE 

REM 

SPAGE 

PAGE  S 
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IIACP850  ^ 

GROUP  FORM  I  t  II  DESTRING/DECOOE  PROGRAM  07-06-S.' 

14:47:41 

Offset  Data  Source  Line  IBM  Personal  Conputer  BASIC  Compiler  LI. 00 


0S5B 

11EE 

GOSUB  1000 

■MAKE  SURE  THEY  ARE  LOGGED  OH 

0560 

11EE 

CLS 

0564 

11EE 

GOSUB  7000 

■PRINT  SCREEN  HEADING 

0569 

11EE 

0569 

11EE 

REM 

REH 

OPEN  FILE  TO  CONTAIN  SCANNED  DATA 

0569 

11EE 

REM 

0569 

11EE 

REM 

0569 

11EE 

OPEN  DAT FILS 

FOR  APPEND  AS  «1 

057B 

11EE 

057B 

11EE 

REH 

*««*««-***«**«***#«**««*«4«*«**«**«SHk**«*«*tt*«*****«************»*« 

057B 

057B 

0578 

11EE 

11EE 

11EE 

REM 

REM 

**** 

CLEAR  AND  DISPLAY  PROGRAM  SCREEN 

•*** 

LPRIMT  CHRSdS); 

0586 

11EE 

WIDTH  “LPT1:' 

,160 

0590 

11EE 

PAGE  »  0  :  GOSUB  7100  'LINE  PRINTER  HEADING 

059C 

11F0 

COLOR  14 

05A5 

11F0 

LOCATE  11,26 

:  PRINT  "GROUP  i  *  II  FORMS  " 

0588 

11F0 

COLOR  FORE, BACK, BORO 

OSCE 

OSCE 

OSCE 

OSCE 

11F0 

11F0 

11F0 

11F0 

REM 

REM 

REM 

•«*« 

COMMUNICATIONS  SETUP 

OSCE 

11F0 

REM 

PROTOCOL 

OSCE 

11F0 

GOSUB  9001 

0503 

11F0 

IF  ERRMSGS  > 

"  "  THEN  LPRINT  ERRMSGS  :  GOTO  30000 

05ED 

11F4 

05ED 

11F4 

REM 

START  SCANNER 

(SI) 

OSEO 

11F4 

CNTRLOPT  =  1 

:GOSUB  9010 

05F9 

11F6 

IF  ERRMSGS  > 

“  "  THEN  LPRINT  ERRMSGS  :  GOTO  30000 

0613 

11F6 

0613 

11F6 

LOCATE  22,25: 

PRINT  "PRESS  ■ESC^  TO  TERMINATE  SCANNING  " 

0628 

11F6 

REAOTrPE»3 

■FIRST  TIME  IN..  SCANNER  IS  STARTED.. 

062  F 

11F8 

062F 

11F8 

REM 

062F 

11F8 

REM 

SET  SCAN  SHEET  CALL 

062F 

11F8 

REM 

062F 

11F8 

062F 

11F8 

REM 

062F 

11F8 

REM 

*** 

BEGIN  WITH  READING  GROUP  FORM  I 

**• 

062F 

11F8 

REN 

062F 

11F8 

062F 

11F8 

6 

AS: INKEYS 

0638 

11FC 

IF  AS=CHRS(27)  THEN  GOTO  25000 

064E 

11FC 

064E 

11FC 

064E 

IIFC 

GOSUB  9020 

■SOAN  SUBROUTINE  •  GET  A  RECORD 

0653 

11FC 

IF  MIDS(ERRSTAIS,14,3)=''415'*  THEN  GOTO  25000 

066F 

1200 

REA0TYPE=2 

■CHANGE  TO  READ  SUBSEQUENT  SHEETS 

0676 

1200 

TEXTS:"" 

■CLEAR  THE  INPUT  AREA 

067F 

1200 

TEXT  IIS:"" 

■CLEAR  THE  INPUT  AREA  FOR  GROUP  FORM  II 

0688 

1204 

COSUB  8000 

■DECODE  HEADER 

0680 

1204 

COSUB  8050 

■CHECK  FOR  END  OF  JOB/ENO  OF  BATCH 

0692 

1204 

GOSUB  8200 

■DECODE  THE  RESPONSE  POSITIONS 

MCPSSO 

GROUP  FORM  I  ft  II  DESTRING/DECODE  PROGRAM 


Offset 

Data 

0697 

1204 

0697 

1204 

06A9 

1208 

06AE 

1208 

06B3 

1208 

06B3 

1208 

06B3 

1208 

06B3 

1208 

0683 

1208 

06C8 

1208 

06D2 

120A 

06E6 

120A 

06EB 

120  A 

06EF 

120A 

06EF 

120A 

06F4 

120A 

06F4 

120A 

06FA 

120A 

0702 

120E 

0702 

120E 

0707 

120E 

070B 

120E 

0708 

t2oe 

U708 

120E 

0708 

120E 

070B 

120E 

070C 

120E 

070C 

120E 

0713 

1210 

071 C 

1210 

0732 

1210 

0732 

1210 

0737 

1210 

>.753 

1210 

075C 

1210 

0761 

1210 

0761 

1210 

0761 

1210 

076F 

1214 

076f 

1214 

0777 

1214 

07d8 

1214 

0790 

1214 

:  795 

1214 

0795 

1214 

079A 

1214 

079F 

1214 

079F 

1214 

073F 

1214 

07B7 

1214 

07B7 

1214 

07BF 

1214 

07D3 

1214 

07E5 

1214 

PAGE  7 
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7  LITHOS  >  MIDS(TEXTS,22,a) 

GOSUB  8070  'CHECK  FOR  SCANNER  ERRORS 
GOSUB  8100  'PRINT  THE  DATA  ON  THE  SCREEN 

REM  **•  EXPECT  A  GROUP  FORM  I  TO  BE  READ  HERE  ••«*•••••«« 

REM  **•  CHARACTERS  IN  POSITION  22  AND  23  SHOULD  BE  NONBLANK 
REM  IF  TYPE  I  w******************** 

IF  MIOSTTEXTS, 22,2)0''  •  THEN  8  'GO  IF  OK 
N.ERR>1 

ED.MSGS(N.ERR)°''GROUP  FORM  I  NOT  READ-CHECK  SEQUENCE" 

GOSUB  995  'PRINT  ERROR  AND  REJECT 

GOTO  6  'GO  BACK  AND  READ  NEXT  SHEET 

8  GOSUB  100  'EDIT  GROUP  I  FORM  RECORD 

REM  IS  THERE  A  CONTINUATION  7  •***"«**••••*•••*•** 

IF  CSHEETS«"1"  THEN  12  'READ  NEXT  FORM  tl  -  CONTINUATION 

GOSUB  200  'WRITE  THE  OUTPUT 

GOTO  6  'BACK  TO  READ  NEXT  SHEET 

»»*♦*#»»*♦#**•*»•*♦*»**«*♦*»*******«»— »l^»»^*^^^**♦*^»^r»***»**«** 

REM  **•  READ  CROUP  FORM  II  *** 

****•«*«*♦*•♦**♦*******•♦*******•♦*♦**♦»••*♦«**•***************** 

12  REH 


EOJUO 

A$=1NKEY$ 

IF  AS=CHRS<27)  THEN  GOTO  25000 

GOSUB  9020  'SCAN  SUBROUTINE  -  GET  A  RECORD 

IF  MIDS<ERRSTAT$,U,3)="L15"  THEM  GOTO  25000 
TEXTS*""  'CLEAR  THE  INPUT  AREA 
GOSUB  8000  'DECODE  HEADER 

REM  •**  EOF  TEST 

IF  PROGRAMS  =  PGMIDS  THEN  U  'GO  ON  IF  NOT  EOF 


N.ERR*N.ERR  +  1 

E0.NSG$(N.ERR)*"E0F  when  EXPECTING  A  GROUP  II  FORM" 
GOSUB  995  'PRINT  ERROR  AND  REJECT 

GOSUB  8050  'GO  QUIT 

U  GOSUB  8200  'DECODE  THE  RESPONSE  POSITIONS 
GOSUB  8070  'CHECK  FOR  SCANNER  ERRORS 

REM  IS  This  form  ii  -  it  should  be  *•••*••*••••••••*•**• 

IF  HIDS(TEXTS,22,2)="  "  THEM  16  'GO  CHECK  LITHO  MATCH 

N.ERR=N.ERR*1 

EO.MSGS(N.ERR)="NO  GROUP  II  FORMS  READ  FOR  THIS  LITHO" 
LPRINT  "LITHO  *  ";LITHOS,-''  ...ERRORS" 

FOR  1997  *  1  TO  HERR 


RACP850 

GROUP  FORM  I  t  II  OESTRING/OECCOE  PROGRAM 


Offset  Data  Source  Line 


PAGE  8 
07-06-87 
U:.7:41 

IRH  Osrcnnjil  Cmmtmr  rnnni  I  Sr  VI  00 


07F2 

1216 

LPRIMT  USING  “;!997; 

07FE 

1218 

LPRIMT  ««>  '•;ED.MSGS(I997} 

08U 

1218 

NEXT  1997 

082S 

1218 

GOTO  7  ’FORGET  THE  GROUP  It  AND  EDIT  THIS  ONE 

0829 

1218 

0829 

1218 

REM 

**•  CHECK  TO  SEE  IF  LITHO  MATCHES  ••••••*~***»«**«««»*««**« 

0829 

1218 

16 

IF  MIDS(TEXT$,24,6)=MIO$(LITHOS,3,6)  THEN  18  'OK  IF  MATCH 

0848 

1218 

0848 

1218 

N.ERR>N.ERR+1 

0850 

1218 

ED.MSGS(N.ERR)’="LITHO  MISMATCH  FROM  FORM  I  TO  FORM  II» 

0864 

1218 

GOSUB  995  ’PRINT  ERROR  ANO  REJECT 

0869 

1218 

GOTO  6  ’START  OVER 

0860 

1218 

0860 

1218 

18 

REM  **■  ACCUMULATE  THE  GROUP  FORM  II  INFO 

086E 

1218 

TEXTI IS»TEXTI IS*MI0S< TEXTS, 30, 165) 

0883 

1218 

0883 

1218 

REM 

•*«««««•*«••**•«*««««***«***•*****«*«**«**•**«*******•***««**«••• 

0883 

1218 

REM 

•••  READ  NEXT  RECORD  -  UNSURE  IF  I  OR  It  OR  EOF  •** 

0883 

1218 

REM 

*♦***«**«*«****••««**•*«•**•««**«**«*«**«**•*«•****••**••**♦«*•*• 

0883 

1218 

20 

ASz INKEYS 

0880 

1218 

IF  AS«CHRS(27)  THEN  GOTO  25000 

oaA2 

1218 

08A2 

1218 

GOSUB  9020  ’SCAN  SUBROUTINE  •  GET  A  RECORO 

0847 

1218 

IF  MI0S<ERRSTATS,14,3)<«’’415"  THEN  GOTO  25000 

08C3 

1218 

0803 

1218 

TEXTS* . CLEAR  THE  INPUT  AREA 

08CC 

1218 

GOSUB  8000  ■ DECODE  HEADER 

0801 

1218 

0801 

1218 

REM 

EOF  TEST 

0801 

1218 

IF  PROGRAMS  <>  PGMIDS  THEN  30  ’TIME  TO  QUIT 

080  F 

1218 

GOSUB  8200  ’DECODE  THE  RESPONSE  POSITIONS 

08E4 

1218 

08E4 

1218 

REM 

IS  THIS  FORM  I  OR  H 

08E4 

1218 

IF  MID$(TEXTS,22,2)*"  "  THEN  28  ’GO  IF  FORM  II 

08FC 

1218 

08FC 

1218 

REM 

*♦*  FORM  I  READ  -  PROCESS  OLD  INFO  BEFORE  PROCEDING 

08FC 

1218 

08FC 

1218 

GOSUB  200  'WRITE  THE  OLD  INFO  OUT 

0901 

1218 

0901 

1218 

TEXTI IS*""  ’RESET  FORM  II  INFO  BUFFER 

090A 

1218 

LITHOS  *  MID$(TEXTS,22,8) 

0910 

1218 

GOSUB  8070  ’CHECK  FOR  SCANNER  ERRORS 

0921 

1218 

GOTO  8  ’BACK  TO  EDIT  THE  NEW  FORM  I  INFO 

0925 

1218 

0925 

1218 

28 

GOSUB  8070  ’CHECK  FOR  SCANNER  ERRORS 

092A 

1218 

GOTO  16  ’THEN  BACK  TO  PROCESS  THE  FORM  II  SHEET 

092E 

1218 

092E 

1218 

30 

GOSUB  200  ’WRITE  THE  LAST  INFO  OUT 

0933 

1218 

GOSUB  8050  ’LET  THIS  SUBROUTINE  QUIT  FOR  US 

0938 

1218 

0938 

1218 

REM  SINCLUDE:  ’RACH850.MO1 ’  INCLUDE  THE  READ  FORM  REFORMAT/EDIT  MOO 

0938 

1218 

REM 

0938 

1218 

REM 

AMBULATORY  CARE  INFORMATION  SYSTEM  10  JUN  87  "*** 

0938 

1218 

REM 

••••  D  R  BOLLING 

RACP8S0 

GROUP  FORM  I  &  II  DESTRING/DECOOE  PROGRAM 
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Data 

0938 

1218 

0938 

1218 

09iJ 

1218 

0938 

1218 

0938 

1218 

0938 

1218 

0938 

1218 

0938 

1218 

0938 

1218 

0938 

1218 

093F 

1218 

093F 

1218 

093F 

1218 

093F 

1218 

0955 

121A 

0967 

121E 

0967 

121E 

0967 

121E 

0967 

121E 

0967 

121E 

0967 

121E 

097F 

1222 

097F 

1222 

097F 

1222 

0991 

1226 

09A3 

122A 

09B5 

122E 

09CA 

122E 

09EA 

122E 

09F8 

1232 

OAOA 

1236 

OAIC 

123A 

0A4A 

123C 

CA78 

123C 

0A78 

123C 

0A81 

1240 

0A86 

1240 

0A95 

1240 

0A9O 

1240 

0AC3 

1240 

0AC3 

1240 

0AC3 

1240 

0AO5 

1244 

0,  E7 

1248 

0AE7 

1243 

0AE7 

1248 

0AF6 

1240 

0AF6 

124C 

0AF6 

1240 

C30a 

1250 

0808 

1250 

OBOG 

1250 

CB1A 

1254 

CTIA 

1234 
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REM 

REM 

REM 

REM 

REN 

REH 

REM 

REH 


*««« 

MODULE  NAME 

RACM850.MO1 

**** 

SCANNER  PROGRAM  «  : 

GROUP  I  FORM 

**** 

***« 

•*«« 

PURPOSE 

REFORMAT/EDIT  THE  FORM 

*«** 

************************* 

•*** 

*«*«***• 

RESERVED  LIME  NUMBERS  100-199 

*****************  «***********JHk******«*********««******  ************ 


100  N.ERR  *0  'COUNTS  THE  NUMBER  OF  ERRORS 


REM  •••  LITHO  CODE  DONE  IN  BAS  PROGRAM  *** 

REM  *•*  CLINIC  10  (PREFIX  ♦  CODE)  *•* 

102  CK.X*VAL(MIDS<TEXTt.30,1)) 

CX . COO$»M I DS( TEXTS , 3 1 , 3 ) 

REH  GOSUB  5500  'OUTP  UCA  CODE  CHECK 

REM  IF  RT.5500  *  0  THEN  GOTO  102 
REM  N.ERR  *  N.ERR  *  1 
REM  ED.MSGS(N.ERR)*«INVALIO  CLINIC  COOE” 

CL1.C0OS*CLINIC1.PFXS(CK.X)  *  CK.COOS  'HAND  COOED 


REM  VISIT  DATE 

104  CMS=MI0S{0ATE$,1,2)  'CURRENT  MONTH 

YR$*MI0$(DATE$,9,2)  'CURRENT  YEAR 

XS*:HI0$(TEXTS,34,4)  'MONTH  AND  DAY 

IF  LEFT$(X$,2)«CM$  THEN  105  'OK,  USE  THIS  YEAR 
YR$=RIGHT$<STRS<VAL(YRS)-1),2)  'USE  LAST  YEAR 

105  VIDATE$=YR$+XS 
D1$=MID$(X$,3,1) 

D2$=MI0S(X$,4,1) 

IF  D1$="  "  AND  02$<>‘'  "  THEN  RT. 5000=2  :  GOTO  106 
IF  01$<>"  "  AND  02$="  "  THEN  RT. 5000=2  :  GOTO  106 
'EDIT  VISIT  DATE 

CK.5000S=VIDATE$ 

GOSUB  5000  'DATE  CHECK 

IF  RT. 5000=0  THEN  GOTO  107 

106  N.ERR=N.ERR*1 

ED.MSG$(N.ERR)="VISIT  DATE"  ♦  DATEERR$(RT.5000) 


REM  PRIMARY  PROVIDER  *•* 

107  PPROV.PFX$=MID$(TEXT$,38,1) 
PPR0V.NUM$=MID$<TEXT$,39,4) 

REM  •**  FORM  NUMBER  **• 
FRMN$=LEFT${PGMID$,2) 

REM  •**  VISIT  COUNT 

112  VCNTS=HI0S<TEXTt,43,1) 

REM  •*»  PRIMARY  PROVIDER  TIME  SPENT 

113  PPR0V.TIM$=MID$(TEXT$,44,3) 

RcM  *♦*  SECONDARY  PROVIDER  *** 


RACPSSb 
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0B1A 

1254 

SPROV.PFX$=MID$(TEXTt,47,1) 

082C 

1258 

SPROV . NUMSsMI D$( TEXTS , 48 , 4 ) 

0B3E 

125C 

IF  SPROV.PFXS-fSPROV.NUHS  ■  ■  ••  THEN  SPBL-I  ELSE  SPBL°0 

0B63 

125E 

IF  SPROV.PFXSc"  ■  ANO  SPROV.NUMSo"  ■  THEN  114 

0B89 

125E 

IF  SPROV.PFXS<>»  "  ANO  SPROV.NUMS*"  »  THEN  114 

08AF 

125E 

GOTO  115 

0BB3 

125E 

0BB3 

125E 

114 

N.ERR  >  H.ERR  +  1 

OBBB 

125E 

ED.MSG$(N.ERR)<"PROV  2  CODE  MISSING  PREFIX  OR  NUMBER" 

OBCF 

125E 

OBCF 

125E 

OBCF 

125E 

REN 

SECONDARY  PROVIDER  TINE  *•* 

OBCF 

125E 

115 

TEMPS=:M  I  D$<  TEXTS ,  52 , 3  ) 

0BE1 

1262 

REM  PAD  WITH  LEADING  ZEROS 

0BE1 

1262 

IF 

TEMPS*"  "  THEN  TEMPS*"000" 

0BF8 

1262 

IF  LEFTS<TEHP$,2)="  ■  THEN  TEMP»«“00“  ♦  RICHT$(TEMP$.1) 

0C22 

1262 

IF 

LEFTS(TEMPS,1)*“  "  THEN  TENPS»"0"  ♦  RIGHTS(TEMPS,2) 

0C4C 

1262 

SPR0V.T1MS*1EMPS 

OCSS 

1266 

REM 

IS  THERE  A  TIME  ANO  NO  SEC  PROV  COOED? 

0C55 

1266 

IF  SPROV.TIHS  >  *000"  ANO  SPBL  «  1  THEN  116  'GO  IF  YES 

0C78 

1266 

REN 

IS  THERE  NO  TIME  ANO  A  SEC  PROV  CtOED? 

0C78 

1266 

IF  SPROV.TIMS  *  *000"  ANO  SPBL  *  0  THEN  117  'GO  IF  YES 

0C98 

1266 

GOTO  118 

0C9F 

1266 

0C9F 

1266 

116 

N.ERR  *  N.ERR  ''  1 

OCA? 

1266 

ED.MSGS{N.ERR)*"TI.HE  CODED  WITH  NO  SEC  PROV  COOED" 

OCBB 

1266 

GOTO  118 

OCBF 

1266 

OCBF 

1266 

117 

N.ERR  •  N.ERR  *  1 

0CC7 

1266 

EO.MSG$(N.ERR)*"NO  PROV  2  TIME" 

0CD8 

1266 

OCOB 

1266 

118 

REN 

OCOC 

1266 

REN 

**•  UNIT  10  CODE  ••• 

OCDC 

1266 

120 

UIC$=MI0S<TEXT$,55,6) 

OCEE 

126A 

OCEE 

126A 

REN 

TIME  PREP  PROV  1  ••• 

OCEE 

126A 

122 

TIMPR1$=MID$(TEXT$,61,3) 

0000 

126E 

0000 

126E 

REN 

TIME  PREP  PROV  2 

0000 

126E 

124 

TIMPR2$=MID1(TEXT$,64,3) 

0012 

1272 

0012 

1272 

REM 

**•  TIME  TRAV  PROV  1 

0012 

1272 

126 

TIMTR1$*MID$(TEXTS,67,3) 

0024 

1276 

0024 

1276 

REN 

•••  TIME  TRAV  PROV  2  **• 

0024 

1276 

128 

TIMTR2S=MID$(TEXT$,70,3) 

0036 

127A 

0036 

127A 

REM 

NO.  ARMY  ACTIVE  **• 

0036 

127A 

130 

NACTS=MID$ITEXT$,73,3) 

0048 

127E 

0048 

127E 

REM 

***  NO.  OTHER  ACTIVE  •** 

0048 

127E 

132 

NOTH$*MIO$(TEXT$,76,3) 

OOSA 

1282 

0O5A 

1282 

REN 

***  NO.  RETIRED  •*• 
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1 

0D5A 

1282 

134 

NRET$=MID$(TEXT$,79,3) 

0D6C 

1286 

006C 

1286 

REM 

•**  NO.  DEPENDENTS 

0D6C 

1286 

136 

N0£PSsMI0t<TEXTf,82,3) 

0O7E 

128A 

007E 

128A 

REM 

•**  MO.  CIVILIANS  •** 

0O7E 

128A 

138 

NCIVS^IDS(TEXTS.85,3) 

0090 

128E 

X90 

128E 

REM 

CONT.  SHEET  **• 

X90 

128E 

140 

CSHEETS=MID$(TEXT$,88, 1 ) 

XA2 

128E 

0DA2 

128E 

REM 

***  ADDITIONAL  PROCEDURE  1  *•* 

ODK2 

128E 

146 

A00P1S=MI0$(TEXT$,89,5) 

XB4 

1292 

X64 

1292 

REM 

•••  EVALUATION/SERV/PROC  PROV  1 

XB4 

1292 

150 

X=VAL<HI0i<TEXT$,94,2)) 

XCA 

1294 

PROC$-PROCEO$(X) 

XDC 

1298 

XOC 

1298 

IF  A00P1S="  ••  AND  PROCS=“  "  THEN  152 

XFF 

1298 

IF  ADDPiSo"  "  AND  PROC$<>“  «  THEN  154 

0E22 

1298 

IF  PROCS-"  *  THEN  PROCS=AOOP1$ 

0E39 

1298 

GOTO  199 

0E3O 

1298 

0E30 

1298 

152 

N.ERR  s  N.ERR  +  1 

0E45 

1298 

ED.MSG$(N.ERR)=“NO  REASON  CXED" 

0E59 

1298 

GOTO  199 

0E5D 

1298 

0E50 

1298 

154 

N.ERR  =  N.ERR  +  1 

0E6S 

1298 

ED.MSG$(N.ERR)="HORE  THAN  ONE  REASON  CXEO" 

0E79 

1298 

0E79 

1298 

199 

REM 

0E7A 

1298 

RETURN 

REM 

0E7D 

1298 

REM  SINCLUDE;  ■RACM850.MO2'  REM  INCLUDE  THE  BASE 

FORM  DISK  WRITER 

PE7D 

1298 

REM 

0E7D 

1298 

REM 

AMBULATORY  CARE  INFORMATION  SYSTEM 

11  JUM  87 

*«*■* 

0E7D 

1298 

REM 

**«* 

D  R  BOLLING 

**«« 

0E7D 

1298 

REM 

****  MODULE  NAME  :  RACM850.MOO 

*«** 

0E7D 

1298 

REM 

SCANNER  PROGRAM  #  :  GROUP  FORM  I  i 

It 

**** 

0E7D 

1298 

REM 

**** 

0E7D 

1298 

REM 

PURPOSE  :  CREATE  AND  WRITE  THE  DISK 

**** 

0E7D 

1298 

REM 

*•••  RECORD  FOR  INPUT  TO  FOCUS 

vE7D 

1298 

REM 

**«* 

**** 

0E7D 

1298 

REM 

OF  70 

1298 

REM 

****  RESERVED  LINE  NUMBERS  200-299 

**«* 

0E7D 

1298 

REM 

0E7D 

1298 

OEH) 

1298 

REM 

BUILD  THE  OUTPUT  RECORD 

0E7O 

1298 

0E7D 

1298 

200 

GOSUB  276  'BUILD  THE  RECORD  KEY 

0E82 

1298 

0E22 

1298 

REM 

A  i  A 

0E3? 

0E02 

1290 

1290 

REM 

REM 

RECORD  TYPE  "1"  -  HAIM  TRANSACTION 

***« 

IBM  Personal  Coniputer  BASK 
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0E82  1298 

0E82  1298  GOSUB  278  'BUILD  DATA  FOR  TYPE  1 

0E87  1298  RECOUTS  =PGMID$+"1"+RECICEYt+RECOT1$  'TRAMSACTION  ID  PLUS  RECORD 

0EA1  12A4  GOSUB  280 

0EA6  12A4  PRINT  #1, RECOUTS 

0EB1  12A4 

OEBI  12A4  REM  *•********«****««**«***«**«****••«»«**•*««*«*****••***#•««*******«* 

0EB1  12A4  REM  RECORD  TYPE  "2"  •  RECKEY  PLUS  PROCEDURE  CODE 

0E81  12A4  REM 

0EB1  12A4 

0EB1  12A4  202  REC002$=PROCS 

OEBA  12A8 

OEBA  12A8  R£COUTS=PGMlDt+"2"+RECKEYS+“1"+REC0O2$  'TRANSACTION  ID  PLUS  RECORD 

OEOA  12A8  GOSUB  280 

OEDF  12A8  PRINT  «1, RECOUTS 

OEEA  12A8 

OEEA  12A8  204 

OEEB  12A8  REN 

OEEB  12A8  REM 

OEEB  12A8  REM 

OEEB  12A8  220 


OEEC 

12A8 

OEEC 

12A8 

REM 

»**«**«««*«s 

»««••*«« 

OEEC 

12A8 

REM 

*•**  RECORD  TYPE  "4"  -  RECKEY 

PLUS  OTHER 

COOES 

OEEC 

12A8 

REM 

OEEC 

12A8 

230 

REM  END  OF  TYPE  4  RECORDS 

DEED 

12A8 

DEED 

12A8 

REM 

»****♦«« 

DEED 

12A8 

REM 

••••  RECORD  TYPE  "5"  -  RECKEY 

PLUS  GROUP 

I  DATA 

DEED 

12A8 

REM 

DEED 

12A8 

232 

REM 

OEEE 

12A8 

OEEE 

12A8 

REM 

UNIT  ID  CODE  ••• 

OEEE 

12A8 

RECOOSSs  UICS 

0EF7 

12AC 

0EF7 

12AC 

REM 

TIME  PREP  PROV  1  ••• 

0EF7 

12AC 

RECQ05S  =  RECOOSS  *  TIMPR1S 

0F03 

12AC 

0F03 

12AC 

REM 

•*»  TIME  PREP  PROV  2  **• 

0F03 

12AC 

RECOOSS  =  RECOOSS  ♦  TIMPR2S 

OFOF 

12AC 

OFOF 

12AC 

REM 

TIME  TRAV  PROV  1 

OFOF 

12AC 

RECOOSS  =  RECOOSS  ♦  TIMTR1S 

0F1B 

12AC 

0F1B 

12AC 

REM 

TIME  TRAV  PROV  2  •** 

0F1B 

12  AC 

RECOOSS  =  RECOOSS  ♦  TIMTR2S 

0F27 

12AC 

0F27 

12AC 

REM 

**♦  NO.  ARMY  ACTIVE  **• 

0F27 

12AC 

RECOOSS  <  RECOOSS  +  NACTS 

0F33 

12AC 

0F33 

12AC 

REM 

***  NO.  OTHER  ACTIVE  •*» 

OF  33 

12AC 

RECOOSS  =  RECOOSS  ♦  NOTHS 

0F3F 

12AC 

REM  END  OF  TYPE  2  RECORDS 

******************************************************************* 
****  RECORD  TYPE  "3"  -  RECKEY  PLUS  SPECIFIC  PRE  CLINIC  COOES 

************************««*«*******************«******«*«*********e 

REM  END  OF  TYPE  3  RECORDS 
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0F3F 

12AC 

RECOOSS  s  RECOOSS  *  NRETS 

0F4B 

12AC 

0F4B 

12AC 

REN 

•**  MO.  DEPENDENTS  ••• 

0F4B 

12AC 

RECOOSS  >  RECOOSS  *  NDEPS 

0F57 

12AC 

0f57 

12AC 

REM 

*•*  NO.  CIVILIANS 

0F57 

12AC 

RECOOSS  s  RECOOSS  *  NCIVS 

0F63 

12AC 

0f63 

12AC 

REM 

***  CONTINUATION  SHEET  *** 

0f63 

12AC 

RECOOSS  s  RECOOSS  ♦  CSHEETS 

0F6F 

12AC 

0F6F 

12AC 

RECOUTS^PGM  ICS+"S"+RECKEYS'»RECQOSS  •  TRANSACT  I  ON 

ID 

PLUS  RECORD 

0F89 

12AC 

GOSUB  280 

OFSE 

12AC 

PRINT  «1,RECOUTS 

0F99 

12AC 

0F99 

12AC 

240 

REM  END  OF  TYPE  S  RECORDS 

0F9A 

12AC 

0F9A 

12AC 

REN 

***•*•**«*******«««*««********«**«****«*****«•«««***•**********«*«* 

0F9A 

12AC 

REM 

RECORD  TYPE  "A"  -  RECKEY  PLUS  SSN  AND  FMP 

**** 

0F9A 

12AC 

REM 

0F9A 

12AC 

0F9A 

12AC 

PTR=1 

0FA1 

12AE 

242 

IF  LEN(TEXTUS)<  PTR  THEN  250 

OFBO 

12AE 

RECOOAS=M 1 0S<  TEXT  n  S , PTR , 1 1 ) 

0FC3 

12B2 

IF  RECOOAS=SPACES(11)  THEN  244 

0FD5 

12B2 

0F05 

1282 

RECOUTS=PGM  I  DS+'‘A"+RECKEYS+REC00AS  •  TRANSACT  I  ON 

ID 

PLUS  RECORD 

OFEF 

1282 

GOSUB  280 

0FF4 

1282 

PRINT  #1,RECOUTS 

OFFF 

1282 

OFFF 

1282 

244 

PTR=PTR+11 

1009 

1282 

GOTO  242 

1000 

1282 

1000 

1282 

250 

REM  ENO  OF  TYPE  A  RECORDS 

100E 

1282 

GOTO  299 

1012 

1282 

1012 

1282 

REM 

N****«********** 

1012 

1282 

REN 

•••♦  SUBROUTINE  270  -  BUILD  THE  RECORD  KEY 

•  *** 

1012 

1282 

REM 

^**-************* 

1012 

1282 

276 

RECKEYS="“ 

101B 

1282 

101B 

1282 

REM 

***  CLINIC  ID  (PREFIX  +  COO)  **• 

101B 

12B2 

RECKEYS=  CLI.COOS 

1024 

12B2 

1024 

1282 

REM 

**»  VISIT  DATE 

1024 

1282 

RECKEY$=RECKEYS+  VIDATES 

'030 

1282 

l030 

1282 

REM 

**•  PRIMARY  PROVIDER  **• 

1030 

1282 

RECKEYS  =  RECKEYS  +  PPROV.PFXS  +  PPROV.NUMS 

1043 

12B2 

1043 

1282 

REM 

***  PATIENT  SSN  *♦* 

1043 

12B2 

RECKEYS  =  RECKEYS  ♦  STRINGS(9,‘'  •') 

ICbS 

1282 

1055 

1282 

PEN 

***  FAMILY  ^-rH8ER  PREF  **• 
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18 

1055 

1282 

RECKEYt  =  RECKEYS  ♦  »  " 

1061 

1282 

1061 

1282 

REM 

LITHO  CODE  •*» 

1061 

1282 

REOKEYS  =  RECKEYS  ♦  LITHOS 

1060 

1282 

1060 

1282 

REM 

•••  FORM  NUMBER 

1060 

1282 

RECKEYS  -  RECKEYS  *  FRMNS 

1079 

1282 

1079 

1282 

RETURN 

107C 

1282 

107C 

1282 

REM 

107C 

1282 

REM 

SUBROUTINE  272  -  BUILD  THE  DATA 

FOR 

TYPE 

^  *•«* 

107C 

1232 

REM 

t**«*1 

107C 

1282 

278 

REC001S=‘"' 

1085 

1282 

1085 

1282 

REM 

VISIT  COUNT  ••• 

1085 

1282 

REC001S  3  REC001S  ♦  VCNTS 

1091 

1282 

1091 

1282 

REM 

PRIMARY  PROV  TIME 

1091 

1282 

RECOOIS  =  REC001S  ♦  PPROV.TIMS 

1090 

1282 

1090 

1282 

REM 

•••  SECONDARY  PROVIDER 

1090 

1282 

RECOD1S  =  RECOOIS  ♦  SPROV.PFXS  +  SPROV.NUMS 

1080 

1282 

1080 

1282 

REM 

•••  SECONDARY  PROVIDER  TIME  •** 

1080 

1282 

RECOTIS  =  RECOOIS  ♦  SPROV.TIMS 

10BC 

1282 

10BC 

1232 

REM 

REASON  FOR  SECONDARY  PROVIDER 

1080 

1282 

REM 

•**  appointment  status 

1080 

1282 

REM 

REFERRAL  COOE  *»• 

1080 

1282 

REM 

•**  PLACE  OF  VISIT  •** 

1080 

1282 

REM 

•••  JOB  RELATED  VISIT 

1080 

1282 

REM 

•»*  MIL  ONLY  DUTY  *** 

1080 

1282 

REH 

MIL  ONLY  QTRS  **• 

1080 

1282 

REM 

♦**  MIL  ONLY  PROFILE  *** 

1080 

1232 

REM 

NOT  AVAILABLE  *** 

1080 

1232 

REM 

•••  ADMITTED 

1080 

1282 

REM 

INFIELD  ••• 

1080 

1282 

REH 

•••  INJURY 

1080 

1282 

REM 

*»*  PURPOSE  OF  VISIT  *•* 

1080 

1282 

REH 

**•  PRIM  FOLLOW-UP/RULE  OUT  ••* 

1080 

1282 

REM 

•**  PRIMARY  DX  COOE  »** 

1080 

1282 

RECOOIS  =  RECOOIS  ♦  STRINGS(22,"  ") 

10CE 

1282 

100E 

1232 

RETURN 

1001 

1232 

1001 

1282 

REM 

1001 

1282 

REH 

•**•  SUBROUTINE  280  -  PAD  THE  RECORD  TO 

MAXLENGTH  •••• 

1001 

1282 

REM 

1001 

1282 

280 

PAD=MAXLENGTH  -  LEN(RECOUTS)  'FIND 

OUT 

MOW 

SHORT  THE  RECORD  IS 

lOOf 

1234 

RECOUTS  =  RECOUTS  ♦  STRINGSCPAD.PADS) 

•PAD  THE 

RECORD  WITH  FILL  CHAR 

10F2 

1284 

RETURN 

lOfS 

1284 

10f5 

1284 

299 

REM 

RACP850 

GROUP  FORM  1  &  U  DESTRING/DECOOE  PROGRAM 
Offset  Data  Source  Line 

10F6  1284  RETURN 

10F9  1284  REM . ENO  OF  MODULE  RACM850.MOO . 

10F9  1284 

1  0F9  1 2B4  REM  #*«*«*«««*•**«**♦«***•*««**«*•«***•****«*««•*««***•********•««*«* 

10F9  12BA  REM  •**  ERROR  CHECK  AMO  PRINT  ROUTINE  *** 

10F9  12B4  REN  •*««*******«***■**«•**•«««**«*******•«***•*******•****«***«*•****• 

10F9  1284  995  IF  N.ERR  =  0  THEN  GOTO  996 

1108  1284  LPRINT  “LITMO  «  ■■;LITH01;“  ...ERRORS" 

111A  1284  FOR  1997  =  1  TO  N.ERR 

1127  1286  LPRINT  USING  "###  ";I997; 

1133  1286  LPRINT  “~>  ";E0 .MSG$(  1997) 

1149  1286  NEXT  1997 

115A  1286  LN. COUNT  =  LM. COUNT  ♦  N.ERR  ♦  1 

1166  1288  CNTRLOPT  =  6 

1160  1288  GOSU8  9010  'REJECT  THE  FORM 

1172  1288  996  RETURN 

1175  1288 

1175  1238 

1175  1288  998  REM  CONTINUE 

1176  1288 

1176  1288  999  GOTO  6 

117A  1288 

1174  1288  REM  ENO  OF  SCAN/OECOOE/WRITE  LOOP 

I17A  1288 

117a  1288  1000  REM  SINCLUOE:  'RACSIOOO.SUB*  INCLUDE  THE  VERIFY  LOGON  SUB 

1178  1288  REM 

1178  1288  REM  *  NAME:  RACS1000  LOGON  VERIFICATION  SUBROUTINE  • 

1178  1238  REM  »  Date:  28  Feb  84  PATIENT  REGISTRATION  PROGRAM  • 

1178  1288  REM  **""*"********************************************»****''***«is******* 

1178  1288  REM  PATIENT  OMR  INPUT  PROGRAM  * 

1178  1288  REM  * 

1178  1288  REM  This  program  verifies  user  is  logged  on  properly.  If  there  is  no  * 

1178  1288  REM  valid  user  logged  on  at  the  time  of  execution,  this  subroutine  will* 

1178  1288  REM  chain  to  the  logon  program  RACP05,  otherwise  a  return  is  issued.  • 

1178  1288  REM 

1178  1238  REM  RESERVED  LINE  NUMBERS  ARE  1001  THRU  1010 

1178  1288  REM 

1178  1288  1001  OPEN  "I",1 ."RACLOG.OAT" 


1180  1288  IF  EOF(1>  THEN  1002  'MAKE  THEM  LOG  ON  FIRST 

1198  1288  INPUT  #1 ,USER$(1 ) ,0T$,TM$,PI0$ 

11BC  12C4  IF  USERSd)  »  ""  THEM  1002  'MAKE  THEM  LOG  ON  FIRST 

11CA  12C4  IF  USERS(I)  =  »•••*•*'■  THEN  1002  'HAKE  THEM  LOG  ON  FIRST 

1'iD8  12C4  CLOSE  1 

1UF  12C4  SCREEN  0,1, 0,0 

11F5  12C4  COLOR  FORE, SACK, BORO 

1208  12C4  CLS 

’20F  12C4  RETURN 

1212  12C4 


1212  12C4  1002  CLOSE 

1216  1204  CHAIM  "RACP05" 

iriD  12C4  '===========£80  OF  LOGON  VERIFY  SUBROUTINE  1000=========================== 

12'D  12C4 

ICO  12C4  2000  REM  SIpriuDE:  'OAC' 2000  .SUB  •  INCLUDE  THE  RIPLY/DELAT  SUB 

12'.:  12C4  Ri^M  . . . 
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121E 

12C4 

REM 

**•« 

AMBULATORY  CARE  DATA 

BASE  13  APR  85 

121E 

12C4 

REM 

**** 

SKIP  COLE 

***« 

121E 

12C4 

REN 

**** 

SUBROUTINE  NAME 

RACS2000.SU8 

**** 

121E 

12C4 

REM 

**** 

SCANNER  PROGRAM  * 

ALL 

«**• 

121E 

12C4 

REN 

#«** 

FUNCTION 

THIS  SUBROUTINE  MODULE 

**** 

121E 

12C4 

REM 

**■*« 

SERVERS  AS  A  UAIT  AND  REPLY 

**** 

121E 

12C4 

REN 

**** 

ENTRY  MODULE 

***« 

121E 

12C4 

REM 

**«* 

INPUT 

SINGLE  KEYBOARD  ENTRY 

***• 

121E 

12C4 

REM 

*««* 

**** 

121E 

12C4 

REM 

*■*«* 

OUTPUT 

KEYBOARD  ENTRY  -  UPPER  CASE 

121E 

12C4 

REM 

•*** 

**** 

121E 

12C4 

REM 

«*«* 

RESERVED  LINE 

•  **» 

121E 

12C4 

REM 

**** 

NUMBERS  :  2001-2010 

121E 

12C4 

REM 

121E 

12C4 

2001 

REM  REPLY  FUNCTION 

121f 

12C4 

2002 

REPLY$=INI(EY$  :  IF  REPLYS="“  THEN  2002 

1233 

12C8 

REPLT=ASC(REPLYS) 

1230 

12CA 

IF  REPLY 

>  90  THEN  REPLYS=CHR$(REPLT  XOR  32)  'CONVERT  TO  CAPS 

1258 

12CA 

IF  REPLYl  <  “A"  OR  REPLYS  >  "2“  THEN  REPLY»=“7" 

1284 

12CA 

RETURN 

1287 

12CA 

1287 

12CA 

5000  REM  SINCLUOE:  <RACS5000.SUB'  INCLUDE  THE  DATE  EDITOR  SUB 

1288 

12CA 

REM 

«««*•*** 

1238 

12CA 

REN 

«••• 

AMBULATORY  CARE  DATA 

BASE  13  APR  85 

•*** 

1288 

i2CA 

REM 

**«* 

SKIP  COLE 

•  *** 

1288 

12CA 

REM 

**«* 

subroutine  name 

RXXS5000.SUB 

#**• 

1288 

12CA 

REN 

SCANNER  PROGRAM  # 

ALL 

1288 

12CA 

REM 

FUNCTION 

THIS  SUBROUTINE  MODULE 

1288 

12CA 

REM 

*««• 

PERFORMS  A  DATE  EDIT 

•  ••* 

1288 

12CA 

REM 

*«■*« 

**«* 

1288 

12CA 

REM 

**** 

INPUT 

DATE  TO  BE  CHECKED  MUST  BE 

**** 

1288 

12CA 

REM 

**** 

IN  THE  VARIABLE  NAMED 

1288 

12CA 

REM 

■CK.5000S' 

•*** 

1288 

12CA 

REM 

IN  THE  FORMAT  "YYMMOO" 

1288 

12CA 

REM 

**•* 

•*** 

1288 

12CA 

REM 

**** 

OUTPUT 

'RT.5000'  IS  THE  RETURN  CODE 

1288 

12CA 

REM 

«*** 

VARIABLE.  IF  THIS  VARIABLE 

*««* 

1288 

12CA 

REM 

«*** 

CONTAINS  ANY  NUMBER  OTHER 

**«• 

1288 

12CA 

REM 

**** 

THAN  0,  AN  ERROR  WAS  FOUND 

***• 

1288 

12CA 

REM 

**«* 

IN  THE  DATE. 

**** 

1288 

12CA 

REM 

«*** 

***« 

1288 

12CA 

REM 

*♦** 

RESERVED  LINE 

«*«• 

1288 

12CA 

REM 

*««* 

NUMBERS 

:  5001-5009 

**«* 

1288 

12CA 

REM 

1288 

12CA 

RT. 

5000  =  0 

128F 

12CA 

CKYEAR  *  VAL(LEFT$(CK.5000$,2))  'YEAR  NUMERIC  VALUE 

12A2 

12CC 

CKMONTH  =  VAL(MID$(CK.5000$,3,2))  'MONTH  NUMERIC  VALUE 

12S8 

12CE 

CKOAY  »  VAL(RIGHT$(CK.5000$,2))  'DAY  NCMERIC  VALUE 

12CB 

1200 

12CB 

1200 

IF  CKMONTH  <  1  THEN  RT. 5000=1  :  GOTO  5009 

12E1 

1200 

IF  CKMONTH  >  12  THEN  RT. 5000=1  :  GOTO  5009 

12F7 

1200 

IF  CKOAY  <  1  THEN  RT. 5000=2  :  GOTO  5009 

1300 

1200 

IF  CKOAY  >  31  THEN  RT. 5000=2  :  GOTO  5009 

1323 

1200 

RACP8S0 
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1323 

1200 

REM 

LEAP  YEAR  CHECK 

1323 

1200 

H0LEHGTH(2)  <  28 

132A 

1200 

IF  CKMONTHo  2  THEN  GOTO  5005  'MUST  BE  FEBRUARY 

1339 

1200 

IF  (CKYEAR  MOO  4)  o  0  THEN 

GOTO  5005  'MUST  BE  A  LEAP  YEAR 

134E 

1200 

NOLEN6TH(2}  >  29 

1355 

1200 

1355 

1200 

5005 

IF  CKDAY  >  MOLENGTH(CKMONTH)  THEN  RT. 5000=3  :  GOTO  5009 

1374 

1200 

1374 

1200 

5009 

RETURN 

1377 

1200 

1377 

1200 

1377 

1200 

1377 

1200 

5500  REM  INCLUDE:  <RACS5500.SUB' 

INCLUDE  THE  OUTP  UCA  VALIDATE  SUB 

1378 

1200 

5600  REH  INCLUDE:  • RACS5600 . SUB • 

INCLUDE  THE  INP  UCA  VALIDATE  SUB 

1379 

1200 

1379 

1200 

6000 

REM  SINCLUOE:  'RACSBOOO.SUB* 

INCLUDE  THE  INSTRING  DECODE  SUB 

137A 

1200 

REM 

*■**«***«♦«»*«*•*«****•*•*******•** 

137A 

1200 

REM 

*•**  AMBULATORY  CARE  DATA  BASE  13  APR  85 

•  *•« 

137A 

1200 

REM 

•«*« 

SKIP  COLE 

«*** 

137A 

1200 

REM 

*•••  SUBROUTINE  NAME 

:  RXXS6000.SUB 

«*•* 

137A 

1200 

REM 

*•••  SCANNER  PROGRAM  # 

:  ALL 

137A 

1200 

REM 

•••*  function 

:  THIS  SUBROUTINE  MODULE 

*•** 

137A 

1200 

REH 

«*«* 

PERFORMS  INSTRING  SEARCH 

137A 

1200 

REM 

*•*« 

137A 

1200 

REH 

••••  INPUT 

:  STRING  TO  BE  SEARCHED  MUST 

•  «** 

137A 

1200 

REM 

«**• 

BE  IN  THE  VARIABLE  NAMED  ; 

*«** 

137A 

1200 

REM 

**«* 

•XS' 

137A 

1200 

REM 

137A 

1200 

REM 

••••  OUTPUT 

:  'TOT'  =  TOTAL  NUMBER  OF 

**** 

137A 

1200 

REM 

***• 

HITS  IN  THE  DESTRING 

137A 

1200 

REM 

' HOLDS! )'  IS  THE  ARRAY 

«*** 

137A 

1200 

REN 

**** 

CONTAINING  THE  NUMERIC 

**** 

137A 

1200 

REH 

**** 

VALUE  OF  THE  HIT  POSITIONS 

*•** 

137A 

1200 

REM 

**«* 

137A 

1200 

REM 

********1^*********»1»**«*««*****«**-»*****«««*«#*****************«**« 

137A 

1200 

REH 

••••  RESERVED  LINE 

*«** 

137A 

1200 

REM 

NUMBERS 

:  6001-6009 

•  *** 

137A 

1200 

REH 

***** 

137A 

1200 

6001 

PTR  =  INSTRIXS,"!") 

1388 

1200 

TOT  =  0 

138F 

1202 

WHILE  PTR  >  0 

139A 

1202 

TOT=TOT+1 

13A2 

1202 

HOLO$(TOT)  =  RIGHT$(STR$<PTR),2) 

13C4 

1202 

PTR=PTR+1 

liCC 

1202 

PTR  =  INSTR(PTR,X$,''1") 

130E 

1202 

WEND 

13E2 

1202 

RETURN 

13E5 

1202 

K  L™ 

LNU  Ui  •tUpn^UllNt  KaX^0vU\a«5vO 

13E5 

1202 

.3E5 

1202 

13F5 

1202 

7000 

REM  SINCLUOE:  'RACS/OOO.SUB' 

INCLUDE  THE  SCREEN  HEADER  SUB 

13C6 

1202 

REM 

RACP850 
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13E6 

1202 

REM 

AMBULATORY  CARE  DATA 

BASE  13  APR  85 

*•*« 

13E6 

1202 

REM 

•««* 

SKIP  COLE 

13E6 

1202 

REM 

*«««r 

SUBROUTINE  NAME 

RACS7000.SUB 

13E6 

1202 

REM 

*«*• 

SCANNER  PROGRAM  « 

ALL 

**** 

I3E6 

12)2 

REM 

FUNCTION 

THIS  SUBROUTINE  MODULE 

***• 

13E6 

1202 

REM 

PRINTS  THE  STANDARD  SCREEN 

*••• 

13E6 

1202 

REM 

•**« 

HEADING. 

**•* 

13E6 

1202 

REM 

INPUT 

COMMON  VARIABLE  USERS(2) 

**«• 

13E6 

1202 

REM 

SYSTEM  DATE 

13E6 

1202 

REM 

**•* 

13E6 

1202 

REM 

OUTPUT 

SCREEN  HEADING 

**•* 

13E6 

1202 

REM 

•*«« 

***• 

13E6 

1202 

REM 

•**« 

RESERVED  LINE 

•«** 

13E6 

1202 

REM 

*«*« 

NUMBERS 

7001-7010 

13E6 

1202 

REM 

13E6 

1202 

13E6 

1202 

7001 

LOCATE 

1.1 

13F0 

1202 

PRINT  "U.S.  ARMY  AMBULATORY  CARE  INFORMATION  SYSTEM" 

13F8 

1202 

LOCATE 

1.65 

UOS 

1202 

PRINT  DATES; 

UOO 

1202 

LOCATE  2,1 

141A 

1202 

PRINT  “USER  ;  «;USERS<1) 

1427 

1202 

RETURN 

142A 

1202 

142A 

1202 

7100  REM  SINCIUOE:  'RACS7100.SUB'  INCLUOE  THE  PRINTER  HEADER  SUB 

142B 

1202 

REM 

***** 

142B 

1202 

REM 

*«** 

AMBULATORY  CARE  DATA 

BASE  13  APR  85 

**** 

142B 

1202 

REM 

•  **« 

SKIP  COLE 

**•* 

142B 

1202 

REM 

SUBROUTINE  NAME 

RXXS7100.SUB 

***• 

142B 

1202 

REM 

SCANNER  PROGRAM  * 

ALL 

**** 

142B 

1202 

REM 

FUNCTION 

THIS  SUBROUTINE  MODULE 

**** 

142B 

1202 

REM 

**«• 

PRINTS  THE  STANDARD  HEADING 

la.:  ** 

142B 

1202 

REM 

**** 

ON  THE  PRINTER. 

**** 

142B 

1202 

REM 

INPUT 

DATE, PAGE, PGHIDS.PGMTITLS 

*♦** 

142B 

1202 

REM 

*«** 

•*** 

142B 

1202 

REM 

•«** 

ou*:  IT 

PRINTER  HEADING,  LN. COUNT 

***• 

142B 

1202 

REM 

*••• 

**** 

142B 

1202 

REM 

RESERVED  LINE 

**** 

142B 

1202 

REM 

NUMBERS 

7101-7110 

•*** 

142B 

1202 

REM 

*«•** 

142B 

1202 

142B 

1202 

7101 

IF  PAGE  >  0  THEN  LPRINT  CHRS(12); 

1441 

1202 

LPRINT 

••ARMY  AMBULATORY  CARE  INFORMATION  SYSTEM _ •';PGMTITLS; 

144E 

1206 

LPRINT 

TAB<70);DATE$ 

1461 

1206 

PAGE=PAGE+1 

1469 

1206 

LPRINT 

••PROGR  AM  •• ;  PGM  I  OS ;  T  AB  ( 70 ) ;  ••PACE  •• ; 

1486 

1206 

LPRINT 

USING  ••####••; PAGE 

1492 

1206 

LPRINT 

149A 

1206 

LN.C0UNT=3 

14At 

1206 

RETURN 

14A4 

1206 

14A4 

1206 

8000 

REM  SIN 

:lude:  •RACSSOOO.SUB^ 

INCLUOE  THE  DECODE  SUB  GROUP 

14A5 

1206 

REM 

***** 

14A5 

1206 

REM 

*•** 

AMBULATORY  LARE  DATA 

BASE  13  APR  85 

*** 

RACP8S0 
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14AS 

1206 

REM 

****  SKIP  COLE 

14A5 

1206 

REM 

SOBROOrrHE  NAME  :  Rxxssooo.sua 

**• 

14A5 

1206 

REM 

SCANNER  PROGRAM  #  ALL 

*** 

14a5 

1206 

REM 

FONCTtON  :  THIS  SUBROUTINE  MODULE 

#** 

14A5 

1206 

REM 

****  IS  A  GROUPING  THAT  PERFORMS 

**• 

14AS 

1206 

REM 

•***  VARIOUS  DECODING  FUNCTIONS 

**« 

14AS 

1206 

REM 

ON  THE  SCANNER  DATA 

*** 

14A5 

1206 

REM 

#««« 

*•* 

14AS 

1206 

REM 

8001  -  OECOOE  THE  HEADER  POSITIONS  (POINTER  0-20) 

14A5 

1206 

REM 

8050  -  CHECK  FOR  END  OF  JOB 

*«• 

14A5 

1206 

REM 

8100  -  PRINT  THE  HEADER  DATA  ON  THE  SCREEN 

•  ** 

14A5 

1206 

REM 

8200  -  OECOOE  THE  RESPONSE  POSITIONS  (POINTER  21-..) 

*•* 

14AS 

1206 

REM 

••••  (RSTURNEO  IN  TEXTS  STRING  VARIABLE) 

*•* 

14A5 

1206 

REM 

*«** 

14A5 

1206 

REM 

•••*  INPUT  :  SHEET  RECORD,  RECORD  LENGTH 

•  ft* 

14  AS 

1206 

REM 

•ft* 

14A5 

1206 

REM 

*•**  OUTPUT  :  ‘TEXTS*  TRING  VARIABLE 

*** 

HAS 

1206 

REM 

*«*« 

•ft* 

14A5 

1206 

REM 

**•*  RESERVED  LINE 

•ft* 

14A5 

1206 

REM 

NUMBERS  ;  8001*8500 

ftftft 

14  AS 

HAS 

12D6 

1206 

REH 

14AS 

1206 

•OECOOE  THE  HEADER  ONLY 

HAS 

1206 

8001 

POINTER  »  0 

14AC 

1208 

RECOROPTR  «  VARPTR(SHEETREC(0)) 

1483 

120  A 

FOR  J8000  =  1  TO  21 

14BA 

120A 

8002 

TEXTS=  TEXT$+CHRS<PEEK(RECOROPTR  ♦  POINTER)) 

1408 

120  A 

P0IHTER=P0INTER+1 

14E0 

120  A 

NEXT  J8000 

14EF 

12DC 

PROGRAMS*  LEFT$(TEXT$,3) 

14FE 

12DC 

BATCHS*  MID$(TEXTS,4,3) 

iSIO 

12E0 

SERIALS*  MIDS(TEXTS,7,4) 

1522 

12E4 

RUNIDS*  MI0S(TEXTS,11,1) 

1534 

12E8 

rc««S*  MIDS(TEXTS,12,2) 

1546 

12EC 

POCKET$=  MI0S(TEXTS,14,1) 

1558 

12F0 

SCANERR1S*MIDS(TEXT$,16,2) 

156A 

12F4 

SCANERR2S*M I0$(TEXT$,18,2) 

157C 

12F8 

SCAHERR3$=M I 0$( TEXTS , 20 , 2 ) 

158E 

12FC 

GOTO  8500 

1592 

12FC 

1592 

12FC 

8050 

REM  CHECK  FOR  END  OF  JOB/ENO  OF  BATCH 

1j93 

12FC 

IF  PROGRAMS  *  PGMIDS  THEN  GOTO  8500 

15A5 

12FC 

LPRIMT  STRINGS(80,"*") 

1583 

12FC 

LPRINT 

1588 

12FC 

LPRINT  "RECORDS  PROCESSED  ...  ".’SERIALS 

15C8 

12FC 

LPRINT  "STARTED  AT  .  ";8TIME$ 

1505 

12FC 

LPRINT  "ENOEO  AT  . ".’TIMES 

;5E2 

12FC 

LPRIMT  CHR$(12) 

15E0 

12FC 

GOTO  30000 

15F1 

12FC 

15f1 

12FC 

8070 

REH  CHECK  FuR  SCANNER  ERRORS 

1  F2 

12FC 

IF  POCKETS  =  "  "  GOTO  8500 

1604 

12FC 

LPRINT  LdHQS; 

160C 

12FC 

LPRINT  "  ...  SCANNER  ERRORS  : 

RACP6S0 

GROUP  FORM  I  t  11  DESTRING/DECOOE  PROGRAM 


Offset 

Data 

1614 

12FC 

1621 

12FC 

162E 

12FC 

1636 

12FC 

163E 

12FE 

1642 

12FE 

1642 

12FE 

1643 

12FE 

1650 

12FE 

1650 

12FE 

166A 

12FE 

1677 

12FE 

1684 

12FE 

1691 

12FE 

1695 

12FE 

1695 

12FE 

1696 

12FE 

1690 

12FE 

16A4 

12FE 

16B1 

1300 

16CF 

1300 

1607 

1300 

16E8 

1300 

16E8 

1300 

16EB 

1300 

16EB 

1300 

16EB 

1300 

16EB 

1300 

16EC 

1300 

16EC 

1300 

16EC 

1300 

16EC 

1300 

16EC 

1300 

16EC 

1300 

16EC 

1300 

16EC 

1300 

16EC 

1300 

16EC 

1300 

16EC 

1300 

16EC 

1300 

16EC 

1300 

16EC 

1300 

16EC 

1300 

16EC 

1300 

16EC 

1300 

16EC 

1300 

16EC 

1300 

16EC 

1300 

16EC 

1300 

16EC 

1300 

16EC 

1300 

16E0 

1300 

16F4 

1300 

16FB 

1300 

PAGE  20 
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Source  Line  IBM  Personal  Conputer  BASIC  Conpiler  VI. 00 


LPRIMT  SCAMERR1S;"  /  »; 

LPRIMT  SCANERR2$;"  / 

LPRINT  SCANERR3t 

LN<LN«1 

GOTO  999 

8100  REM  PRINT  THE  HEADER  VARIABLES  ON  THE  TUBE.... 

LOCATE  5,1:PRINT  xpflOGRAM  »;PROGRAMS; 

PRINT  ••  BATCH  o.-BATCHS; 

PRINT  RUN  ";RUNI0S; 

PRINT  “  FORM  ".-FORMS; 

PRINT  "  POCKET  “.-POCKETS 

GOTO  8500 

8200  REM  DECODE  THE  RESPONSE  POSITIONS 
POINTER  *  21 

RECORDPTR  *  VARPTR(SHEETREC(0)) 

FOR  J8000  *  22  TO  RECOROLENGTH 
8202  TEXTS  «  TEXTS+CHR$(PEEK<BECORDPTR  ♦  POINTER)) 

POINTER"POtNTER*1 
NEXT  J8000 

8500  RETURN 

REM . ENO  OF  RXXS8000.SU8 . . 

9000  REM  SINCLUDE:  >8X039000. SUB <  INCLUDE  THE  SCANNER  CONTROL  SUB 


REM 

REM 

*««« 

AMBULATORY  CARE 

DATA  BASE  13  APR  85 

REM 

**«« 

SKIP  COLE 

REM 

PROGRAM  NAME 

:  RACS9000.SUB 

REM 

SCANNER  PROGRAM 

«  ALL 

REM 

***« 

FUNCTION 

:  THIS  SUBROUTINE  MODULE 

*•*« 

REN 

*•«« 

CONTROLS  THE  SCANNER  I/O 

REN 

*•«« 

REM 

INPUT/OUTPUT 

:  REFER  TO  THE  ASYNCHRONOUS 

REM 

•••* 

COMMUNICATIONS  MANUAL  AND  THE 

REM 

PRE-RELEASED  SOFTWARE  GUIDE 

REM 

•*«* 

REM 

«***« 

REM 

**«« 

RESERVED  LINE 

**•* 

REM 

***« 

NUMBERS 

;  9001-9100 

*•«* 

REM 

***«4 

REM 

REN 

*«*« 

SUBROUTINE  9001  - 

PROTOCOL  SETUP  FOR  SCANNER 

REM 

ARGUMENTS:  PRESET 

...  SEE  BELOW 

REN 

9001 

REM 

PROTOCOL (0)  =  9600  'BAUD  RATE 

PROTOCOL(I)  »  78  'PARITY  (SEE  PAGE  4-8  OF  MANUAL) 

PROTOCOL(2)  =  8  'DATA  BITS 


RACPSSO 

UROUP  FORH  I  t  II  OESTRING/OECOOE  PROCRAM 


PAGE  21 
07-06-87 
K:47:41 


Offset 

Data 

Source 

Line 

IBM  Personal  Loinputer  BASIC  Compiler  VI. 00 

1702 

1300 

PR0T0C0U(3)  »  1  'STOP  BITS 

1709 

1300 

PROTOCOL(4)  «  2  •RS-232  PORT 

1710 

1300 

PROTOCOKS)  >  0  'WRITE  TItC-OUT 

1717 

1300 

PR0T0C0l(6)  «  0  'READ  TIME-OUT 

171E 

1300 

171E 

1300 

ERRSTATS  ■  SPACEStOO) 

172A 

1300 

ARGPTR  >  VARPTR(PROTOCOL(0)) 

1731 

1302 

CALL  SETUP  (ARGPTR, ERRSTATS) 

1742 

1302 

ERRMSGS^*" 

1748 

1302 

IF  ASC(ERRSTAT$)  <>  64  THEN  ERRMSGS^oSETUP  ERROR  x+ERRSTATS 

1767 

1302 

GOTO  9100 

1768 

1302 

1768 

1302 

REH 

1768 

1302 

REH 

*•••  SUBROUTINE  9010  -  CONTROL  OPTIONS  FOR  SCANNER 

***** 

1768 

1302 

REM 

ARGUMENTS:  CNTRLOPT 

1768 

1302 

REM 

CNTRLOPT  «  1  »  START  SCANNER  (SI) 

1768 

1302 

REM 

•••*  CNTRLOPT  *  2  »  STOP  SCANNER  (SO) 

1768 

1302 

REM 

****  CNTRLOPT  >  3  X  TERMINATE  COFfUNICATIONS  TO  SCANNER  (DC3) 

1768 

1302 

REM 

•••*  CNTRLOPT  «  4  »  CLEAR  TRANSPORT  PATH  (0C2) 

***** 

1768 

1302 

REM 

CNTRLOPT  =  5  =  SELECT  PRIMARY  STACKER  *31" 

1768 

1302 

REM 

CNTRLOPT  «  6  «  SELECT  SECONDARY  STACKER  "32" 

1768 

1302 

REM 

*•••  CNTRLOPT  *  7  X  POSITIVE  RESPONSE/SELECT  SCANNER  (DC1) 

1768 

1302 

REM 

••••  CNTRLOPT  X  8  X  REQUEST  STATUS  (ESC) 

1768 

1302 

REH 

1768 

1302 

9010 

REM 

176C 

1302 

ERRSTATS  X  SPACES! 60) 

1778 

1302 

CALL  CNTROL  (CNTRLOPT, ERRSTATS) 

1789 

1302 

ERRMSGSx"" 

1792 

1302 

IF  ASC(ERRSTATS)  <>  64  THEN  ERRHSG$»"C(»ITROL  ERROR  "+ERRSTATS 

17AE 

1302 

GOTO  9100 

1782 

1302 

1782 

1302 

REM 

1782 

1302 

REM 

SUBROUTINE  9020  -  SCAN  SHEET  CALL 

***** 

1782 

1302 

REM 

***# 

1782 

1302 

REM 

*•••  ARGUMENTS:  READTYPE 

1782 

1302 

REM 

READTYPE  *  2  =  REQUEST  NEW  DOCUMENT  FROM  SCANNER 

***** 

1782 

1302 

REM 

READTYPE  =  3  =  RETRANSMIT  CURRENT  DOCUMENT 

***** 

1782 

1302 

REM 

«*«* 

1782 

1302 

REH 

ARGUMENTS:  RECOROLENGTH 

***** 

1782 

1302 

REH 

NUMERIC  VARIABLE  SET  TO  THE  NUMBER  OF  CHARACTERS  TO  BE 

1^2 

1302 

REH 

TRANSMITTED 

1782 

1302 

REM 

IF***** 

1782 

1302 

9020 

REM 

1?83 

1302 

ERRSTATS  x  SPACES(60) 

178F 

1302 

RECORDPTR  »  VARPTR(SMEETREC(0)) 

r-' 

17C6 

1302 

CALL  SCAN  (READTYPE, RECOROLENGTH. RECORDPTR, ERRSTATS) 

17DF 

1302 

ERRMSGSx"" 

1728 

1302 

IF  MIDS(ERRSTAT$,14,3)  »  j^EN  ERRMSGS="ESC" 

1809 

1302 

GOTO  9100 

1800 

1302 

1100 

1302 

REM 

1800 

1302 

REM 

**•*  SUBROUTINE  9030  -  TRANSPORT  PRINT  CALL 

1800 

1302 

REH 

**** 

IfloO 

1302 

REM 

♦•**  ARGUMENTS:  FRINTPOS 

***** 

RACP850 

GROUP  FORM  1  R  II  OESTRING/OECOOE  PROGRAM 


PAGE  2’ 
07-06-87 
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Offset 

Oats 

Source  Line 

IBM  1 

1800 

1302 

REM 

***•  NUMERIC  VARIABLE  INDICATING  THE  STARTING  PRINT  POSITION 

*««♦* 

1800 

1302 

REM 

VALUES  »  0  THRU  90 

1800 

1302 

REM 

*«*« 

***#* 

1800 

1302 

REM 

•••*  ARGUMENTS:  PSTRINGS 

1800 

1302 

REM 

••••  TEXT  TO  BE  PRINTED  ON  THE  FORM 

1800 

1302 

REM 

*«*• 

1800 

1302 

REM 

•***  NOTE:  THIS  ROUTINE  HAS  NO  EFFECT  UNLESS  THE  SCAN 

1800 

1302 

REM 

**■*  HEADER  SHEET  IS  MARKED  'PRINTER  ON' 

1800 

1302 

REM 

**«•****'***•*•*•*  *****«*«*«*«***sk**»«****«*******«*«*«  »***••****••* 

1800 

1302 

9030 

REM 

180E 

1302 

ERRSTATS  -  SPACES(60) 

181A 

1302 

REC0R0P1R  >  VARPTR(SHEETREC(0)) 

1821 

1302 

CALL  TPR I  NT ( PR  I NTPOS , PSTR I NGS, ERRSTATS) 

1836 

1308 

IF  ASC(ERRSTATS)  o  64  THEN  ERRHSGSz"PRINT  ERROR  ■-^ERRSTATS 

18S2 

1308 

GOTO  9100 

18S6 

1308 

1856 

1308 

9100 

RETURN 

1859 

1308 

1859 

1308 

1859 

1308 

REM  ENO  OF  SUBROUTINES  isaasiazssxsizsssszzzassszuzszazzxuzxrzz 

1859 

1303 

1859 

1308 

25000 

REN  USER  TERMINATED  INPUT...  FILE  IS  NOT  TO  BE  USEDHII 

185A 

1308 

LPRINT  ■njSER  TERMINATED  INPUT  ..  DATA  WILL  NOT  BE  USEDI" 

1862 

1308 

LPRINT  "ERASING  FILE  ";DATFILS 

186F 

1308 

BEEP 

1873 

1308 

CLS  :  PRINT  "USER  TERMINATED  INPUT  ..  DATA  WILL  NOT  BE  USEDI" 

187F 

1308 

CLOSE 

1883 

1308 

OPEN  DATFILS  FOR  OUTPUT  AS  #1 

1895 

1308 

PRINT  #1,STRING$(REC0R0LENGTH,"X")  'VOID  THE  FIRST  RECORD 

18A7 

1308 

CLOSE 

18AB 

1308 

18AB 

1308 

30000 

REM 

18AC 

1308 

CLOSE 

18B0 

1308 

CHAIN  "RACP10" 

18B7 

1308 

laBA 

1308 

22151 

Bytes  Available 

U696  Bytes  Free 


0  Warninj  Error(s) 
0  Severe  Error(s) 


PAGE  1 
04-24-87 
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Offset  Data  Source  Line  IBM  Personal  Computer  BASIC  Lonpiler  V1.00 

001A  0002  REM  SLINESIEE:  132 

001A  0002  REM  SPAGEStEE:  66 

001A  0002  REM  STULE:  •RACP860  • 

001A  0002  REM  SSUBTITLE:  • tHHUNlZATlON  SHORT  FORM' 

001A  0002  REM  SPACE 


RAGP860 

IMMUNIZATION  SHORT  FORM 


Offset 

Data 

001A 

0002 

001A 

0002 

001A 

0002 

001A 

0002 

001A 

0002 

001A 

0002 

001A 

0002 

001A 

0002 

001A 

0002 

001A 

0002 

001A 

0002 

001A 

0002 

001A 

0002 

001A 

0002 

001A 

0002 

001A 

0002 

001A 

0002 

001A 

0002 

001A 

0002 

001A 

0002 

001A 

0002 

001A 

0002 

001A 

0002 

001 A 

0002 

001A 

0002 

001A 

0002 

001A 

0002 

001A 

00C2 

001A 

0002 

OOIA 

0002 

001A 

0002 

OOIA 

0002 

OOIA 

0002 

OOIA 

0002 

OOIA 

0002 

OOIA 

0002 

OOIA 

0002 

OOIA 

0002 

OOIA 

0002 

OOIA 

0002 

OOIA 

0002 

OOIA 

0002 

OOIA 

0002 

OOIA 

0002 

OOIA 

0002 

OOIA 

0002 

001A 

0002 

OOIA 

0002 

OOIA 

0002 

001A 

0002 

OOIA 

0002 

OOIA 

0002 

OOIA 

0002 

OOIA 

0002 

PACE  2 
04-,A-87 
12:51:22 

Source  Line  IBM  Personal  Computer  BASIC  Compiler  V1.00 

REM  . . . 

REM  I  NAME:  RACP860  AMBULATORY  CARE  INFORMATION  SYSTEM  | 

REM  I  DATE:  15  APR  87  IMMUNIZATION  j 

REN  j  0  R  BOLLING  SHORT  FORM  | 

REM  I  I 

REM  I  INCLUDES  PREFIX  TO  LITHO  FOR  EACH  PATIENT  ON  FORM  j 

REM  . . . 

REM  IMMUN  SHORT  FORM  INPUT  PROGRAM 

REM 

REM  This  program  reads  the  SHORT  form  OMR  data,  converts  various 
REM  fields,  prints  an  error  report  and  produces  the  file: 

REN 

REM  VISIT. OAT 

REM 

REM  for  input  to  FOCUS.  NOTE  THAT  THIS  FILE  IS  OPENED  FOR  APPEND 
REM  each  time  the  program  is  run.  Thus,  if  the  file  does  not  exist, 

REM  records  Mill  be  added  to  the  front.  If  the  file  exists,  records 
REM  will  be  added  to  the  end  of  the  current  file.  It  is  intended  that 
REM  Che  FOCUS  DIALOGUE  MANAGER  ROUTINE  which  loads  the  data  will  delete 
REM  the  data  file  after  the  load  has  been  successfully  accomplished. 

REM 

REN 

REM  If  there  is  no  valid  user  logged  at  the  time  of  execution,  this 
REM  program  will  chain  to  the  logon  program  RXXP05,  otherwise, 

REM  the  program  chains  to  program  RXXP10  on  exit. 

REM  SINCLUOE:  'RACOIM.MOO'  REM  INCLUDE  THE  DIMENSION  DEFINITIONS 


NAME:  RACOIM.MOO  DIMENSION  DEFINITIONS 

Date:  28  Feb  84  Written  by:  Floyd  Cole 


Dimensioned  variables  are  defined  in  this  file. 

It  is  an  included  file  so  it  cannot  be  run  in  a  stand-alone, 
mode. 

This  program  segment  may  be  modified,  but  all  files  containing 
an  include  for  this  segment  must  be  re-compiled  in  order  to 
affect  the  changes  made  here. 

***•*****««>  START  OF  DIMENSION  DEFINITION  ••••••••*••••*••*••’ 


DEFINT  A-Z 

DIM  USERS(2),M0LENGTH(12),DATEERR$(3) 
*••••••••••*  END  OF  DIMENSION  DEFINITIONS 


REM  DIMENSION  STATEMENTS  UNIQUE  TO  THIS  PROGRAM 


DIM  SHEETREC(1750) 
DIM  PR0T0C0L(7) 

DIM  ED.MSGt(30) 

DIM  CLIMIC1.PFX$(5) 
DIM  PROCED$(39) 

DIM  PTIDt(6) 


•(MAX.  SIZE  FOR  A  SHEET  FROM  THE  SCANNER) 
■(ARRAY  FOR  SERIAL  BOARD  SETUP  PARAMETERS) 
•(ERROR  MESSAGES  FROM  EDIT  ROUTINES) 
'(PREFIX  -B  D  F  G  S-  FOR  CLINIC  #1) 
'(PROCEDURE  TABLE  FOR  SHORT  FORM) 

■(PATIENT  SSN+FMP) 


I 


I 

I 


RACP860 

IHHUMIZATION  SHORT  FORH 
Offset  Data  Source  Line 


PACE  3 
04-24-87 
12:51:22 

ISH  Personal  Canputer  BASIC  Compiler  VI. 00 


I 


I* 


001A 

0002 

001A 

0002 

0Q1A 

0002 

001A 

0002 

001A 

0002 

001A 

0002 

001A 

0002 

001A 

0002 

001A 

0002 

001A 

0002 

001 A 

0002 

001A 

0002 

001 A 

0002 

001A 

0002 

001A 

f  ' 
O 

o 

o 

001A 

0002 

001A 

0002 

001A 

0002 

001 A 

0002 

001A 

0002 

001A 

0002 

001A 

0002 

001A 

0002 

OOIA 

0002 

001A 

0002 

OOIA 

0002 

OOIA 

0002 

001A 

0002 

OOIA 

0002 

OOIA 

0002 

001A 

0002 

OOIA 

0002 

OOIA 

0002 

OOIA 

0002 

OOIA 

0002 

OOIA 

0002 

OOIA 

0002 

OOIA 

0002 

OOIA 

0002 

OO'A 

0002 

uOIA 

0002 

OOIA 

0002 

OOIA 

0002 

OOIA 

0002 

OOIA 

0002 

00h7 

144A 

004E 

144A 

0055 

144C 

rose 

144C 

00(3 

144C 

006A 

144C 

0076 

144C 

0076 

144C 

0070 

K4C 

DIM  T0T.PR0C(6) 
DIM  GRCIUPS(6,39) 
OIH  SPEC0$(6) 
DIM  HOLOS(39) 


■{PROCEDURE  TOTAL  PER  PAT  I  EAT) 
'(PATIENT/PROCEOURE  GROUP) 
•(SPECIFIC  PRE  CODE  GROUP) 

■(HOLD  AREA  FOR  SUBROUTINE  6000) 


REN  SINCLUDE:  <RACCNN.HCD'  REM  INCLIOE  THE  COMMON  AREA  DEFINITION 


i**********«*****i 

NAME:  RACCMN.HOO 
Date:  28  Feb  8i> 


COMMON  AREA  DEFINITION 
Written  by:  Floyd  Cole 


COMMON  AREA  DEFINITIONS  WILL  BE  HELD  IN  THIS  FILE.  IT  IS  AN 
INCLUDED  FILE  SO  IT  CANNOT  BE  RUN  IN  A  ST AND* ALONE,  MODE. 

This  program  segment  may  be  modified,  but  all  files  containing 
an  include  for  this  segment  must  be  re*CQnpiled  in  order  to 
affect  the  changes  made  here. 


'START  Of  COMMON  DEFINITIONS* 


COMMON  FORE, SACK, BOARD, HIDE, EFORE,EBACK, BELLS  ‘BASIC  SCREEN  COLORS 
COMMON  HEADERS  <21  CHARACTER  SCANNER  HEADER  INFO 

COMMON  TEXTS  "  AINING  CHARACTERS  FROM  SCANNER 

COMMON  PGMIDS  ‘PROGRAM  OR  FORM  ID 

COMMON  MOLENGTHO  ‘DAYS  IN  THE  MONTH 

COMMON  USERSO 

*************END  OF  COMMON  DEFINITION************************* 


REM  SINCLUDE:  'RACDEF.HOO’  REM  INCLUDE  THE  DEFAULT  DEFINITIONS 


NAME:  RACP01.DEF  DEFAULT  DEFINITIONS 

Date:  28  Feb  84  Written  by:  Floyd  Cole 


Variables  used  in  common  that  have  a  default  value  on  start'up 
Nil  I  be  held  in  this  file.  It  is  an  included  file  so  it  cannot 
be  run  in  a  stand'alone  mode.  In  normal  operation,  this  file 
should  be  'included'  in  the  main  program  only  (RACP10.BAS) . 

This  program  segment  may  be  modified,  but  all  files  containing 
an  include  for  this  segment  must  be  re'compiled  in  order  to 
affect  the  changes  made  here. 


*************START  OF  DEFAULT  DEFINITION********’ 
FORE  =  15  'FOREGROUND  COLOR  *  INTENSE  WHITE 


BACK  =  1 

BORD  =  4 
HIDE  =  4 
EFORE*  14 
EBACK=  0 
BELLS  =  CHR$(7) 


'Background  Color  ^  Light  Blue 
'BORDER  »  RED 

'ALTERNATE  COLOR  «  RED 
'ERROR  FOREGROUND  DISPLAY 
'ERROR  BACKGROUND  DISPLAY 
'Sound  the  belt 


MOLENCTHd)  =  JI 
HOLEMGTH(2)  =  20 


■JAN 

■FEB  <  -MODIFIED  IN  SUBROUTINE  RACS5000.SUB 


RACP860 

IMMUNIZATION  SHORT  FORM 


PfSE  4 
(K-24-i7 
12:S1.22 

Offset  Data  Source  Line  IBM  Personal  Computer  BASIC  Compiler  fl.OO 


0084 

144C 

NOLENGTH(3} 

=  31 

■MAR 

008B 

144C 

MOLENGTH(4) 

=  30 

•APR 

0092 

144C 

MOLENGTH(5> 

»  31 

•MAY 

0099 

144C 

MOLENGTH(6) 

•  30 

•JUN 

OOAO 

144C 

MOLENGTH<7) 

=  31 

•JUL 

00A7 

144C 

MOLENGTH(8) 

»  31 

■AUG 

OOAE 

144C 

MOLENGTH(9) 

*  30 

•SEP 

OOBS 

144C 

MOLENGTHdO) 

•  31 

■OCT 

OOBC 

144C 

MOLENGTHdD 

=  30 

■NOV 

00C3 

144C 

MOLENGTHdZ) 

=  31 

•DEC 

OOCA 

144C 

OOCA 

144C 

0ATEERR$(0) 

S  ii  M 

00D3 

144C 

DATEERRSd) 

2  "INVALID 

MONTH" 

OOOC 

144C 

0ATEERRS(2) 

a  "INVALID 

DAY  " 

DOES 

144C 

0ATEERRS(3) 

"  "DAY  TOO 

LARGE  FOR  MONTH  COOED" 

OOEE 

144C 

OOEE 

144C 

MAXLENGTN 

»  80 

•MAXIMUM  LENGTH  Of  OUTPUT 

RECORD 

OOFS 

U4E 

PADS 

«  II  II 

•PAD  CHARACTER  FOR  SHORT  RECORDS 

OOFE 

1452 

OOFE 

1452 

**END  OF  DEFAULT  DEFINITION*****"*"***' 

OOFE 

1452 

OOFE 

1452 

OOFE 

1452 

KEY  OFF 

0104 

1452 

0104 

1452 

****«*«****■ 

»*»*****«*«’««1 

0104 

1452 

REM  THE  FOLLOUING  VARIABLES  , 

ARE  UNIQUE  TO  EACH  PROGRAM  AND  MUST 

0104 

1452 

REM  BE  CHANGED. 

0104 

1452 

REM  *********** 

0104 

1452 

PGMTITLS 

=  "IMMUNIZATION  SHORT  FORM" 

0100 

1456 

0100 

1456 

PGMIDS  = 

"860" 

■VALUE  RECEIVED  FROM  THE 

SCAN’IER 

0116 

1456 

•IN  HEADER  VARIABLE  •PROGRAMS^ 

0116 

1456 

0116 

1456 

DATFILS 

=  "VISIT. OAT" 

•file  to  be  INPUT  TO  FOCUS 

011F 

USA 

011F 

USA 

REM  LENGTH  OF  STRING  RECEIVED 

FROM  THE  OMR.... 

011F 

USA 

HEADER  - 

21 

0126 

U5C 

RESPONSE= 

376 

0120 

USE 

RECOROLENGTH  s  HEADER 

»  RESPONSE 

0138 

1460 

0138 

1460 

N.PROC 

"  39  ‘  NUMBER  OF  PROCEDURES  FOR  THIS  FORM 

013F 

1462 

013F 

1462 

REM  *•*•••••••• 

013F 

1462 

013F 

1462 

BTIMES^TIMES 

■SCAN  START  TIME 

0148 

1466 

0148 

1466 

0148 

1466 

REM  *•*  ENCOUNTER  FORM  CLINIC  PREFIX  TABLE  *** 

0148 

1466 

REM  CLINIC 

«1 

0148 

1466 

CLINIC1.PFX$(0>="  " 

0151 

1466 

CLINIC1.PFXSd)  =  "B" 

015A 

1466 

CLIMIC1.PFXS(2>="0" 

0163 

1466 

CLINIC1.PFXS(3)="F" 

016C 

1466 

CLINIC1.PFXS{4)="G" 

RACPe60 

IMMUNIZATION  SNORT  FORM 


03  Z8 
038.i 
O-'OE 
039E 
0333 
O'.DA 


K6C 

U6E 

U6E 

U6E 

U6E 

U.70 


Offset 

Data 

Source  Line 

0175 

1466 

CLINIC1.PFXS(5) 

s«S“ 

01 7E 

1466 

01 7E 

1466 

REM  ENCOUNTER 

FORM  PROCEDURE  TABLE 

*** 

017E 

1466 

PROCED$<0)="  " 

PR0CE0$(14)  =  "90724" 

PROCEDS(28)=  "86580" 

0199 

1466 

PROCEDSd) ="90723" 

PROCED$(15)  =  "90705“ 

PROCEDS(29)=  "86581" 

01 B4 

1466 

PROCED$(2)="90725" 

PR0CE0t(16)  =  "90733" 

PROCEDS(30)=  "86582" 

01CF 

1466 

PROCED$(3)="90701" 

PROCED$<17)  =  "90707" 

PR0CE0$(31)=  "90703'' 

01EA 

1466 

PROCED$(4>="90702" 

PROCEDSdS)  *  “90704“ 

PROCEDS(32)=  "90714" 

0205 

1466 

PROCED$(5)="90718" 

PROCED$d9)  =  “90727“ 

PR0CE0S(33)=  "90717" 

0220 

1466 

PROCED$<6)="90731" 

PROC£DS(20)  =  “90732“ 

PROCEDS(34)=  "90700" 

0233 

1466 

PROCED$(7)="90711" 

PROCEDS(21)  =  "90712“ 

PROCEDS(35)=  "90698" 

0256 

1466 

PROCE0$(8)="90742" 

PROCEDS(22)  =  "90713“ 

PRCICEDS(36)=  "95120" 

0271 

1466 

PROCED${9)="90741" 

PROCEDI (23)  =  "90726“ 

PROCEDS(37)=  "95122“ 

028C 

1466 

PROCED$(10)="9O743" 

:  PROCED$(24)  ="90708“ 

PROCEDS(38)=  "95123" 

02A7 

1466 

PROCED$(11)="90744" 

:  PROCEO$(25)  =“90709" 

PROCEDS(39)=  “95124" 

02C2 

1466 

PROCED$(12)="90746" 

:  PROCED$(26)  ="90706“ 

0204 

1466 

PROCEDt(13)="90747" 

:  PROCEOS<27)  =“90710“ 

02E6 

1466 

02E6 

1466 

REM  INCLUDE:  'UCABAMC.OPT '  INCLUDE  OUTPATIENT 

UCA  TABLE 

02E6 

1466 

02E6 

1466 

GOSUB  1000 

'MAKE  SURE  THEY  ARE  LOGGED  ON 

02E3 

1466 

CLS 

02EF 

1466 

GOSUB  7000 

'PRINT  SCREEN  HEADING 

02f4 

1466 

02F4 

1466 

«***«*«’««*«******««•'*****•**'*•***********••»***'»******#*********•* 

n2F4 

1466 

REM 

OPEN  FILE  TO  CONTAIN  SCANNED  DATA 

«*** 

02F4 

1466 

REM  w********************-***************'********'*******************'*** 

02F4 

1466 

REM 

02F4 

1466 

OPEN  DAT  FILS  FOR  APPEND  AS  #1 

0306 

1466 

0306 

1466 

REM  «*».«*♦.*.»«** 

***tk*«««*******'*'*********1 

f***  1r 

0306 

1466 

REM 

CLEAR  AND  DISPLAY  PROGRAM  SCREEN 

**** 

0306 

1466 

*#*«****«***** 

»**«* 

0306 

1466 

LPRINT  CHR$(15); 

0311 

1466 

WIDTH  "LPT1:", 

160 

0318 

1466 

PAGE  =  0  :  GOSUB  7100  'LINE  PRINTER  HEADING 

0327 

1468 

COLOR  14 

032E 

1468 

LOCATE  11,26  : 

PRINT  "IMMUNIZATION  SHORT  FORM" 

0343 

1468 

COLOR  FORE, BACK, BORO 

0359 

1468 

0359 

1468 

REM  ************** 

0359 

1468 

REM 

COMMUNICATIONS  SETUP 

**** 

0359 

1468 

REM  •**»•**••»**.♦ 

k*********************S 

R**** 

0359 

1468 

REM  PROTOCOL 

03.9 

1468 

GOSUB  9001 

U35E 

1468 

I F  ERRMSGS  > 

"  "  THEN  LPRINT  ERRMSGS 

GOTO  30000 

0373 

146C 

0378 

146C 

REM  START  SCANNER 

(SI) 

PAGE  5 
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CNTRLOPT  =1  :GOSUB  9010 

IF  ERRHSGi  >  "  "  THEN  LPRINT  ERRHSGt  :  GOTO  30000 

LOCATE  22,25:PRINT  "PRESS  'ESC  TO  TERMINATE  SCANNING  " 
READTYPE=3  'FIRST  TIME  IN..  SCANNER  IS  STARTED. 


IUCP860 

IMHUNIZATION  SHORT  FORM 


Offset 

Data 

Soun 

03BA 

1470 

REM 

03BA 

1470 

REM 

03BA 

1470 

REM 

03BA 

1470 

REM 

03BA 

1470 

03SA 

1470 

10  1 

03BB 

1470 

03BB 

1470 

03C4 

1474 

030A 

1474 

030A 

1474 

030  F 

1474 

03FB 

1478 

03FB 

1478 

0404 

1478 

0409 

1478 

040E 

1478 

0413 

1478 

0425 

147C 

042A 

147C 

042F 

147C 

042F 

147C 

042F 

147C 

REM 

042F 

147C 

REM 

042F 

147C 

REM 

042F 

147C 

REM 

042F 

147C 

REM 

042F 

147C 

REM 

042F 

147C 

REM 

042f 

147C 

REM 

042F 

147C 

REM 

042F 

147C 

REM 

042F 

147C 

REM 

042F 

147C 

042F 

147C 

0436 

U7E 

0436 

147E 

REM 

0436 

147E 

0436 

147E 

REM 

0436 

147E 

100 

043F 

1482 

043F 

1482 

REM 

043F 

1482 

0457 

1482 

046D 

1484 

047F 

1488 

REM 

047F 

1488 

REM 

04  7F 

1488 

REM 

04  7F 

1488 

REM 

047F 

1488 

047F 

1488 

0h?7 

1^05 

0497 

1488 

REM 

0497 

1488 

104 

RAGE  6 
04  24-8  ' 
12:51  22 

IBM  Personal  Coaputer  BASIC  Coapilci  VI. 00 


A******************** 


SET  SCAN  SHEET  CALL 


10  REM  -  RETURN  POINT  TO  READ  NEXT  SHEET 
AS> INKEYS 

IF  AS<HRS(27)  THEN  GOTO  25000 

GOSUB  9020  ‘SCAN  SUBROUTINE  -  GET  A  RECORD 

IF  MI0$aRRSTAT$,14,3)«"415“  THEN  GOTO  25000 

TEXTS^""  'CLEAR  THE  INPUT  AREA 
GOSUB  8000  'DECODE  HEADER 

GOSUB  8050  'CHECK  FOR  END  OF  JOB/END  OF  BATCH 
GOSUB  8200  'DECODE  THE  RESPONSE  POSITIONS 
LITHOS  >  MID$(TEXTt,22,8) 

GOSUB  8070  'CHECK  FOR  SCANNER  ERRORS 
GOSUB  8100  'PRINT  THE  DATA  ON  THE  SCREEN 

REM  SINCLUDE:  'RACM860.M01 '  INCLUDE  THE  SHORT  FORM  REFORMAT/EDIT  HOD 


•«** 

«*** 

**** 

•*** 

**** 


AMBULATORY  CARE  INFORMATION  SYSTEM 


MODULE  NAME 
SCANNER  PROGRAM  M 

PURPOSE 


IS  APR  87 
D  R  BOLLING 

RACM860.M01 

860- IMMUNIZATION  (FBIA)  FORM 

REFORHAT/EOIT  THE  ENCOUNTER 
SHORT  FORM  OMR  RECORD. 


***• 

*•*« 

**•* 

**«* 


N.ERR  *0  'COUNTS  THE  NUMBER  OF  ERRORS 

LITHO  CODE  DONE  IN  BAS  PROGRAM  *•* 


*** 


CLINIC  ID 
100  CL1.C00$s"FBIA" 


*** 


'DEFAULT  CLINIC  CODE 


...  CLINIC  CODE  UHEN  HAND  COOED  ... 

IF  MIDS(TEXTS,30,4J="  "  THEN  104 
CK.X=VAL(MI0$(TEXT$,30,1)) 
CK.COOS=MIDS(TEXT$,31 ,3) 

GOSUB  5500  'VALIDATE  OUTP  UCA  CODE 


CL1.COO$»CLIN!C1.PFXS(CK.X)  ♦  CK.COOS 


*•*  VISIT  DATE  *** 
CMS=MIDt(DATE$,1,2) 


'CURRENT  MONTH 


itACP860 

IMMUNIZATION  SHORT  FORM 


Offset 

Data 

Source  Line 

04A9 

HBC 

YRS>MIDS(0ATES,9,2)  'CURRENT  YEAR 

04BB 

1490 

X$«MIDS(TEXTS,3S,4)  'MONTH  AND  DAY  FROM  FORM 

04C0 

1494 

IF  LEFTSCXS.ZIoCMS  THEN  105  'OK,  USE  THIS  YEAR 

04E2 

1494 

YR$«R1CHT$(STRS(VAL(YRS)-1),2)  'USE  LAST  YEAR 

0502 

1494 

105 

VDATES  >  YRS  *  XS 

0510 

1498 

'EDIT  VISIT  DATE 

0510 

1498 

CK.SOOOS^VDATES 

0519 

149C 

GOSUa  5000  'DATE  CHECK 

051E 

149C 

CK.5Q10t>VDATE$ 

0527 

14A0 

GOSUB  5010  'NUMERIC  STRING  CHECK 

052C 

14A0 

IF  RT.5000  <  0  AND  RT.S010  >  0  THEN  GOTO  106 

0550 

14A4 

N.ERR>H.ERR*1 

0558 

14A4 

ED.M$GS(N.ERR}>'<TOOAYS  DATE  *  0ATEERRS( RT.5000) 

057E 

14A4 

057E 

14A4 

REH 

•••  PROVIDER  ID  (PREFIX  ♦  NUM) 

05  7E 

14A4 

106 

PROV1.PFXS  «  MIDS(TEXTS,39,1) 

0590 

14A8 

PROVI.NUMS  «  MIDS(TEXT$,40,4) 

05A2 

14AC 

')5A2 

14  AC 

SSN. 

OFFSET  =  44 

05A9 

14AE 

FMP. OFFSET  »  S3 

0580 

1480 

PRC.OFFSET  *  55 

0537 

1482 

SPE. OFFSET  «  94 

OSSE 

1484 

TOT. 

OFFSET  «  59 

05CS 

14B6 

POINTER  »  0 

05CC 

1488 

05CC 

1488 

REH 

LOOP  THROUGH  THE  FOLLOWING  CODE  6  TIMES  (1  FOR  EACH  GROUP) 

05CC 

1488 

FOR  1411  =  1  TO  6 

U503 

1483 

REM 

PATIENT  ID  (SSN+FMP) 

0503 

1488 

110 

SSN$«MID$(TEXT$,SSN.0FFSET+P0INTER,9) 

05EA 

I4ac 

FHP$=M  tD$<  TEXTS , FMP .OF  FSET+POI NTER , 2 ) 

0601 

14C0 

0601 

14C0 

PTI0$<I411)  »  SSNS+FMPS 

061 A 

14C2 

IF  I411<1  THEN  GOTO  120 

0629 

14C2 

IF  PTI0$(I411)=STRING$(11,"  »)  THEN  GOTO  130 

064F 

14C2 

064  F 

14C2 

REN 

•••  PROCEDURE  COOES 

064  F 

14C2 

120 

X$  «  MIOS(TEXTS.PRC.OFFSETtPOINTER,N.PROC) 

0667 

14C2 

GOSUB  6000  'DECODE  THE  XS  STRING 

066C 

14C2 

IF  TOT  *  0  THEN  GOTO  122 

0678 

14C4 

T0T.PR0C<I411)  «  TOT 

068A 

14C4 

FOR  I411.A=  1  TO  TOT 

0697 

14C6 

PTR=VAL(HOLD$<I411,A)) 

06A0 

14CA 

GROUPS! 1411,1411 . A)=PROCEDS(PTR) 

56CF 

I4CA 

NEXT  1411. A 

06E0 

14CA 

GOTO  124 

06b4 

14CA 

06E4 

14CA 

122 

N.ERR=M.ERR+1 

f  SEC 

14CA 

ED.MSGS(N.ERR)="NO  PROCEDURE  CODE  " 

0700 

14CA 

0700 

14CA 

REM 

SPECIFIC  PREASSIGNEO  COOES 

0700 

14CA 

124 

INP.ST0S=MIDS(TEXTS,SPE.0FFSET*P0IHTER,9) 

07'7 

14CE 

u7)7 

14CE 

GOSUB  5700  'CONVERT  ARRAY  STRING 

one 

14CF 

SPEC0Sn411)=BUf  .STOS  'UP  TO  9  TWO  DIGIT  COOES 

PAGE  7 
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GOSUB  5700 

SPEC0tn411)=BUf  .STOt 


'CONVERT  ARRAY  STRING 
'UP  TO  9  TWO  DIGIT  COOES 


RACPa60 

IMMUNIZATION  SHORT  FORM 


PAGE  R 
04-Z4-8V 
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Offset  Data  Source  Line  IBM  Personal  Computer  BASIC  Compiler  VI. 00 

0730  UD2 

0730  U02  130  POINTER  •  POINTER  *  TOT. OFFSET 

073B  1402  NEXT  1411 

0740  1402 

0740  1402  199  REM 

074E  1402 

074E  1402  REM  . END  OF  MOOULE  RACH860.MO1 . 

074E  1402 

074E  1402 

074E  1402  IF  N.ERR  »  0  THEN  GOTO  997 

0750  1402  LPRINT  "LITHO  «  “;LITHO$;"  ...  ERRORS" 

076F  1402  FOR  1997  =  1  TO  N.ERR 

077C  1404  LPRINT  USING  ‘iWW  “;i997; 

0788  1406  LPRINT  "=*>  “;E0.MSG${I997) 

079E  1406  NEXT  1997 

07AF  1406  LN. COUNT  •  LN. COUNT  ♦  N.ERR  ♦  1 

07BB  1408  CNTRLOPT  «  6 

07C2  1408  GOSUB  9010  'REJECT  THE  FORM 

07C7  1408  GOTO  998  'BYPASS  THE  DISK  WRITER _ 

07CB  1408 

07CB  1408  997  REM  SINCLUOE:  'RACMa60.M02'  REM  INCLUDE  THE  BASE  ENCOUNTER  FORM  DISK  WRITER 


07CC 

1408 

REM 

*«««*«*««*«««*«««««««««***««*******#****««*#*«**«#««*««*«1l*««****«« 

07CC 

1408 

REM 

AMBULATORY  CARE  INFORMATION  SYSTEM  15  APR  87 

07CC 

1408 

REM 

0  R  BOLLING 

07CC 

1408 

REM 

MOOULE  NAME 

:  RACH860.M00 

07CC 

1408 

REM 

SCANNER  PROGRAM  « 

:  860- IMMUNIZATION  SHORT  FORM 

07CC 

1408 

REM 

07CC 

1408 

REM 

••••  PURPOSE 

:  CREATE  AND  WRITE  THE  DISK 

**** 

07CC 

1408 

REM 

RECORD  FOR  INPUT  TO  FOCUS 

07CC 

1408 

REM 

**** 

**** 

07CC 

1408 

REM 

PROGRAM  ADOS  PREFIX 

TO  LITHO  FOR  EACH  PATIENT 

07CC 

1408 

REM 

07CC 

1408 

REM 

*•**  RESERVED  LINE  NUMBERS  200-299 

**** 

07CC 

1408 

REM 

07CC 

1408 

07CC 

1408 

REM 

BUILD  THE  OUTPUT  RECORD 

07CC 

1408 

07CC 

1408 

GOSUB  270  ' 

BUILD  THE  RECORD  KEY 

0701 

1408 

0701 

1408 

REM 

0701 

1408 

REM 

RECORD  TYPE  "2"  - 

RECKEY  PLUS  PROCEDURE  CODE 

***« 

0701 

1408 

REM 

0701 

1408 

REM 

RECOUTS  s"8602''+RECKEY$ 

'TRANSACTION  IDENTIFIER 

0701 

1408 

FRMNS  °  "86" 

'FORM  NUMBER 

07DA 

140C 

070A 

140C 

FOR  1412  =  1  TO  6 

07E1 

140C 

IF  PTID$(I412)=STRINGS(11,"  ")  THEM  GOTO  250 

0807 

140E 

FOR  1412. A  *  1  TO  TOT 

.PROC(I412) 

081B 

14E0 

RECOUTS  =  "8602"  ♦  RECKEYS  + 

RIGHTS(STRS(I412),1)  ♦  RIGHTS(LITH0S,7) 

084B 

14E8 

MIDS{RECOUT$,20,11) 

=PTIDS<I412) 

0863 

14E8 

Pecans  sRFcouTS  ♦ 

'RMHS  ♦  "1"  ♦  GR0UPS(I412,I412.A) 

OSflF 

UEA 

GOSUB  280 

0894 

14EA 

PRINT  Rl, RECOUTS 

089F 

UEA 

NEXT  1412. A 

liACPa60 

tHMUNIZATION  SHORT  FORH 
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( ICC 

Offset 

Dsti 

Source  Line  I8M  Personal  Computer  BASIC  Compiler  VI. 00 

0883 

14EA 

2S0 

NEXT  1412 

08CS 

14EA 

08CS 

14EA 

REM 

*««««*«***««■***■**««*********«**««««*•**«**«*•*•*****•***********•** 

OSes 

14EA 

REM 

****  RECORD  TYPE  "3"  -  RECKEY  PLUS  SPEC  PRE  CLINIC  COOES  •••* 

OSes 

14£A 

REM 

OSes 

14EA 

FOR  1860  3  1  TO  6 

08CC 

14EA 

IF  LEN(SPEC0S(I860))«0  THEN  260 

Q8E2 

14EC 

RPOINT  >  1 

08E9 

14EE 

08E9 

14EE 

252 

REC003S>R I GHTS(M I DS( SPECOSl I 860 ) . RPOI NT , 2) , 1 ) 

0908 

14F2 

IF  REC003SX'  ■<  THEN  254 

0919 

14F2 

0919 

14F2 

RECOUTS>»8603"  +  RECKEYS  «  RIGHTS(STR$(I860).1)  RIGHTS(LITHOS,7) 

0949 

14F2 

MIDS(REC0UT$,20,11)>PT1DS(I860) 

0961 

14F2 

RECOUTS>RECOUT$  *  FRMNS  *  REC003t 

0974 

14F2 

GOSU6  280 

0979 

14F2 

PRINT  iRI.RECOUTS 

0984 

14F2 

0984 

14f2 

254 

RPOINT  »  RPOINT  ♦  2 

0980 

14F2 

IF  RPOINT  <  LEN(SPEC0S(IB60))  THEN  252 

09A5 

UF2 

09A5 

14F2 

260 

NEXT  I860 

0987 

14F2 

0987 

14F2 

REM  END  OF  TYPE  3  RECORDS 

0987 

14F2 

0987 

14F2 

GOTO  299 

0983 

14F2 

0988 

14F2 

REM 

0988 

14F2 

REM 

••••  SUBROUTINE  270  -  BUILD  THE  RECORD  KEY  *••• 

0988 

14F2 

REM 

0988 

14F2 

270 

RECKEYS*"" 

C9C4 

14F2 

0OC4 

14F2 

REM 

•••  CLINIC  ID  (PREFIX  ♦  CODE) 

09C4 

14F2 

RECKEYS*  CL 1. COOS 

09C0 

14F2 

09CD 

14F2 

REM 

*•*  VISIT  DATE  *** 

09C0 

14F2 

RECKEYS=RECKEYS*  VDATES 

O.W 

14F2 

0909 

14F2 

REM 

**•  PROVIDER  ID  (PREFIX  ♦  NUM) 

0909 

14f2 

RECKEYS  *  RECKEYS  ♦  PROV1.PFXS  ♦  PROV1.NUMS 

09EC 

14F2 

09EC 

14F2 

REM 

**•  PATIENT  ID  (SSN+FMP)  ••• 

09EC 

Inrt 

RECKEYS  *  RECKEYS  ♦  STRINGS! 11,"  ") 

l'9FE 

14F2 

09FE 

14F2 

REM 

*•*  LITHO  CODE  *** 

09Fc 

14f2 

REM 

DO  LITHO  IN  LOOP  ABOVE 

09FE 

14F2 

REM 

RECKEYS  *  RECKEYS  ♦  LITHOS 

0''FE 

14F2 

09FE 

14F2 

RETURN 

0A01 

14F2 

0A01 

14F2 

REM 

0A01 

14F2 

REM 

****  SUBROUTINE  280  -  PAD  THE  RECORD  TO  MAXLENGTH  •*** 

0,.01 

14F2 

REH 

0A01 

14F2 

280 

PAO=MAXLENGTH  -  LEN(RECOUTS)  '0 

IWUHIZAriON  SHORT  FORM  04-24-87 


Offset  Data  Source  Line 
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OAOF 

UFA 

0A22 

UFA 

0A25 

UFA 

0A25 

UFA 

0A2S 

UFA 

0A26 

UFA 

0A26 

UFA 

0A26 

UFA 

0A26 

UFA 

0A27 

UFA 

0A27 

UFA 

0A2E 

UFA 

0A3E 

UFA 

0A42 

UFA 

0A42 

UFA 

0A42 

UFA 

0A42 

UFA 

0AA3 

UFA 

0A43 

UFA 

0A43 

UFA 

0AA3 

UFA 

0A43 

UFA 

0AA3 

UFA 

0A43 

UFA 

0A43 

UFA 

0A43 

UFA 

0AA3 

UFA 

0A43 

UFA 

0AA3 

UFA 

0A43 

UFA 

OA55 

UFA 

0A63 

UFA 

0A8A 

1500 

0A92 

1500 

OAAO 

1500 

0AA7 

1500 

0A80 

1500 

0AD3 

1500 

0A07 

1500 

OADA 

1500 

OAOA 

1500 

OAOE 

1500 

OAES 

1500 

0AE5 

1500 

OAES 

1500 

0AE6 

1500 

0AE6 

1500 

0AE6 

1500 

0AE6 

1500 

OAEA 

1500 

0AE6 

1500 

0AE6 

1500 

0AE6 

1500 

0AE6 

1500 

RECOUTS  >  RECOUTS  +  STRlNG$(PAO,PAOS)  'PAD  THE  RECORD  WITH  FILL  CHAR 
RETURN 


299  REM 

REM . END  OF  MODULE  RXXM860.MO2 . . 

998  REM  CONTINUE 

999  REAOTYPE  =  2 

IF  LN. COUNT  >  AS  THEN  GOSUB  7100  'PRINTER  HEADING 
GOTO  10 


REN  ENO  OF  SCAN/DECQOE/URITE  LOOP 


1000 
REM  > 
REM  < 
REM  ' 
REM  ' 
REM 
REM 
REM 
REM 
REN 
REM  ' 
REM 
REM  ' 
1001 


REM  SINCLUOE:  'RACS 1000. SUB'  INCLUOE  THE  VERIFY  LOGON  SUB 


NAME:  RACS1000 
Date:  28  Feb  84 


LOGON  VERIFICATION  SUBROUTINE 
PATIENT  REGISTRATION  PROGRAM 


PATIENT  OMR  INPUT  PROGRAM 

This  program  verifies  user  is  logged  on  properly.  If  there  is  no 
valid  user  logged  on  at  the  time  of  execution,  this  subroutine  will 
chain  to  the  logon  program  RACPOS,  otherwise  a  return  is  issued. 


RESERVED  LINE  NUMBERS  ARE  1001  THRU  1010 


OPEN  "1",1, "RACLOC.DAT" 

IF  EOF(1)  THEN  1002 
INPUT  #1,USERS<1),0TS,TM$,PI0t 
IF  USERSd)  =  ""  THEN  1002 
IF  USERSd)  a  "aaaaaaa  ^h^N  1002 
CLOSE  1 

SCREEN  0, 1,0,0 
COLOR  FORE, BACK, BORO 
CLS 

RETURN 


•MAKE  THEM  LOG  ON  FIRST 

'MAKE  THEM  LOG  ON  FIRST 

•HAKE  THEM  LOG  ON  FIRST 


1002  CLOSE 

CHAIN  "RACPOS" 

•  aaaaaa=aaa:ENO  OF  LOGON  VERIFY  SUBROUTINE  1000“===“===~=*«==*- 


2000 

REM 

REM 

REM 

REM 

REM 

REM 

REM 

REM 

REM 


REM  S INCLUDE:  'RACSaOOO.SUB*  INCLUDE  THE  REPLY/DELAY  SUB 


«**• 

*«** 

**** 


AMBULATORY  CARE  DATA  BASE  13  APR  85 

SKIP  COLE 


SUBROUTINE  NAME 
SCANNER  PROGRAM  « 
FUNCTION 


RACS2000.SUB 

•H 

THIS  SUBROUTINE  MODULE 
SERVERS  AS  A  WAIT  AND  REPLY 
ENTRY  MODULE 
SINGLE  KEYBOARD  ENTRY 


aaaa 

aaaa 

aaaa 

aaaa 

••aa 

aaaa 

aaaa 

aaaa 


*•** 


INPUT 


liACP860 
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0AE6 

1500 

REM 

*«** 

»*** 

0AE6 

1500 

REM 

**«« 

OUTPUT 

:  KEYBOARD  ENTRY  -  UPPER  CASE 

•**« 

0AE6 

1500 

REM 

*«** 

0AE6 

1500 

REM 

**«« 

RESERVED  LINE 

0AE6 

1500 

REM 

**♦* 

NUMBERS 

;  2001-2010 

•*** 

0AE6 

1500 

REM 

«*1l«*** 

0AE6 

1500 

2001 

REM  REPLY  FUNCTION 

0AE7 

1500 

2002 

REPLYt= INKEYS  :  IF  REPLY$="“ 

THEN  2002 

OAFB 

1504 

REPLY»ASC( REPLY!) 

0B05 

1506 

IF  REPLY 

>  90  THEN  REPLY!=CHR!<REPLY  XOR  32)  'CONVERT  TO  CAPS 

0B20 

1506 

IF  REPLY!  <  "A"  OR  REPLY!  >  • 

Z“  THEN  REPLY!*"?" 

0B4C 

1506 

RETURN 

084F 

1506 

0B4F 

1506 

5000 

REM  SINCLUOE:  'RACS5000.SUB 

INCLUDE  THE  DATE  EDITOR  SUB 

0850 

1506 

REM 

0850 

1506 

REM 

***« 

AMBULATORY  CARE  DATA  BASE  13  APR  85 

0850 

1506 

REM 

**«* 

SKIP  COLE 

1850 

1506 

REM 

SUBROUTINE  NAME 

:  RXXS5000.SUB 

**** 

0850 

1506 

REM 

SCANNER  PROGRAM  « 

:  ALL 

**** 

0850 

1506 

REM 

FUNCTION 

:  TMIS  SUBROUTINE  MODULE 

**** 

0850 

1506 

REM 

««•« 

PERFORMS  A  DATE  EDIT 

***« 

0850 

1506 

REM 

**«« 

0850 

1506 

REM 

«**« 

INPUT 

:  DATE  TO  BE  CHECKED  MUST  BE 

0850 

1506 

REM 

IN  the  VARIABLE  NAMED 

0850 

1506 

REM 

•••« 

'CK.5000!' 

**** 

0850 

1506 

REM 

«««* 

IN  THE  FORMAT  “TYMMOO" 

««•« 

0850 

1506 

REM 

**** 

0850 

1506 

REM 

**** 

OUTPUT 

•RT,5000'  IS  THE  RETURN  CODE 

0850 

1506 

REM 

VARIABLE.  IF  THIS  VARIABLE 

0850 

1506 

REM 

«««* 

OWTAINS  ANY  NUMBER  OTHER 

C350 

1506 

REM 

**«* 

THAN  0,  AN  ERROR  WAS  FOUND 

*•** 

0850 

1506 

REM 

**•* 

IN  THE  DATE. 

**** 

0850 

1506 

REM 

*•«« 

0850 

1506 

REM 

RESERVED  LINE 

0350 

1506 

REM 

«««• 

NUMBERS 

;  5001-5009 

*•** 

0850 

1506 

REM 

0850 

1506 

RT. 

5000  =  0 

0857 

1506 

CKYEAR  =  VAL<LEFT!(CK.5000!,2))  'YEAR  NUMERIC  VALUE 

0B6A  1508  CKMONTH  «  VALCMIOSTCK.SOOOS.S.Z))  'MONTH  NUMERIC  VALUE 

0B80  150A  CKDAY  >  VAL(RIGHTS(CK.S000S.2))  'DAT  NUMERIC  VALUE 

0.93  150C 

0893  15CC  IF  CKMONTH  <  1  THEN  RT. 5000=1  ;  GOTO  5009 

0BA9  150c  IF  CKMOMTH  >  12  THEN  RT. 5000=1  :  GOTO  5009 

0B8F  150C  IF  CKDAY  <  1  THEN  RT. 5000=2  :  GOTO  5009 

0SD5  150C  IF  CKDAY  >  31  THEN  RT. 5000=2  :  GOTO  5009 

OSEB  t50C 

IBEB  150C  REM  LEAP  YEAR  CHECK 

OBbB  150C  M0LEHGTH{2)  =  28 

08f2  150C  IF  CKMONTHo  2  THEM  GOTO  5005  'MUST  BE  FEBRUARY 

0C01  150C  IF  (CKYEAR  MOO  4)  <>  0  THEN  GOTO  5005  'MUST  BE  A  LEAP  YEAR 

O'lb  150C  MOLENCTHIZ)  =  29 

OC'.O  150C 

OCID  150C  5005  IF  CKDAY  >  MOLENGTH(CKMONTH)  THEN  RT. 5000=3  :  GOTO  5009 

OCjC  150C 


RACP860 

IMMUNIZATION  SHORT  FORM 


offset 

Data 

0C3C 

150C 

0C3F 

150C 

0C3F 

150C 

0C3F 

150C 

0C3f 

•.sac 

0C40 

150C 

0C40 

150C 

0C40 

150C 

0C40 

150C 

0C40 

150C 

0C4O 

150C 

0C40 

150C 

0C40 

150C 

0C40 

150C 

0C40 

150C 

0C40 

150C 

0C40 

150C 

0C40 

1S0C 

0C4O 

150C 

0C40 

15QC 

OC40 

1S0C 

0C40 

150C 

0C40 

150C 

0C40 

1S0C 

0C40 

150C 

0C40 

150C 

0C40 

150C 

0C40 

150C 

0C47 

150C 

0C47 

150C 

0C57 

1S0E 

0C6B 

1512 

0C93 

1512 

0CA4 

1512 

0CA4 

1512 

0CA7 

1512 

0CA7 

1512 

0CA8 

1512 

0CA9 

1512 

0CA9 

1512 

0CA9 

1512 

0CA9 

1512 

0CA9 

1512 

0CA9 

1512 

0CA9 

1512 

0CA9 

1512 

0CA9 

1512 

0CA9 

1512 

0CA9 

1512 

0CA9 

1512 

0CA9 

1512 

0CA9 

1512 

0CA9 

1512 

0CA9 

1512 

PAGE  12 
04-24-87 
12:51:22 

IBM  Personal  Ccnputer  BASIC  Coispiler  V^.OO 


50C9  RETURN 


REM  - 

5010 

REM 

REM 

REM 

REM 

REM 

REM 

REM 

REM 

REM 

REM 

REM 

REM 

REM 

REN 

REM 

REM 

REM 

REM 

REM 

REM 

REM 

REM 


-END  OF  SUBROUTINE  5000 


REM  SINCIUOE:  'RACS5010.SUB>  INCLUDE  THE  NUMERIC  STRING  EDITOR 


REM  - 

5500 

5700 

REM 

REN 

REM 

REM 

REM 

REM 

REM 

REH 

REM 

REH 

REM 

REH 

REM 

REM 

REM 

REM 


AMBULATORY  CARE  DATA  BASE  1  MAY  85 

**•* 

**«• 

SKIP  COLE 

***« 

SUBROUTINE  NAME  : 

RXXS5010.SUB 

*«•* 

**** 

SCANNER  PROGRAM  »  : 

ALL 

«««* 

FUNCTION  : 

THIS  SUBROUTINE  MODULE 

**** 

**** 

PERFORMS  A  NUMERIC  STRING 

**»• 

*«** 

EDIT. 

***« 

INPUT  : 

STRING  TO  BE  EDITED  IS  IN 

•«** 

THE  VARIABLE  NAMED 

**«♦ 

**** 

•CK.5010S' 

*•«* 

*«*• 

OUTPUT  ; 

■RT.5010*  IS  THE  RETURN  CODE 

•*** 

VARIABLE.  IF  THIS  VARIABLE 

*«** 

•*** 

CONTAINS  ANT  NUMBER  OTHER 

*•*« 

THAN  0,  AN  ERROR  UAS  FOUND 

**«• 

IN  THE  STRING. 

RESERVED  LINE 

NUMBERS  ; 

5011-5019 

RT 

5010  »  0 

FOR  15010  =  1  TO  LEM<CK.5010$) 

J5010«  ASC(M1D$(CIC.5010$, 

15010,1)) 

IF 

J5010  <  48  OR  J5010  > 

57  THEN  RT.5010  «  RT.5010  ♦  1 

NEXT  15010 

RETURN 

REM  INCLUDE:  ■RACS5500.SUB' 

INCLUDE  THE  OUTPATIENT  UCA  CHECK 

SUB 

REM  SINCLUOE:  'RACSSFOO.SUB ■ 

INCLUDE  THE  ARRAY  CONVERTER 

***«« 

**•* 

AMBULATORY  CARE  DATA 

BASE  29  JUL  85 

«*•* 

D  R  BOLLING 

•  *«* 

**•* 

SUBROUTINE  NAME 

RXXS5700.SUB 

•>**« 

scanner  PROGRAM  # 

ALL 

**** 

FUNCTION 

THIS  SUBROUTINE  MODULE 

**** 

CONVERTS  A  BINARY  ARRAY  INTO 

**** 

TWO  CHAR  COOES. 

**«* 

**•* 

**** 

INPUT 

INP.STOS  AS  STRING 

***« 

**«* 

*«** 

**** 

♦  **« 

OUTPUT 

BUF.STOS  AS  STRING. 

**** 

**** 

**** 

**•* 


RESERVED  LINE 


i)ACP860 
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0CA9 

1512 

REM 

**«• 

NUMBERS 

:  5710-5730 

•  *«* 

CCA9 

1512 

REM 

0CA9 

1512 

0CA9 

1512 

BUF.STOS*"" 

0CB2 

1512 

N.STO^I 

0CB9 

15U 

5710 

X.STO=INSTR(H.STO. IMP.STOt, 

"1") 

OCCB 

1516 

IF  X.STO=0  THEN  GOTO  5720 

■THATS  ALL 

OCOA 

1516 

N.STO  X 

X.STO  ♦  1 

•NEXT  STARTING  POINT 

0CE2 

1516 

X.STO  » 

X.STO  ♦  100 

•PAD  WITH  LEADING  ZERO 

OCEC 

1516 

BUF.STOS  *  BUF.STOS  +  RIGHTS(STRS(X.STO),2) 

0002 

1516 

IF  N.STO  <=■  LENCINP.STOS)  THEN  GOTO  5710 

0015 

1516 

0015 

1516 

5720 

RETURN 

0018 

1516 

0018 

1516 

0013 

1516 

6000 

REM  SINCLUDE;  ■ RACS6000 . SUB 

INCLUDE  THE  INSTRING  DECODE  ROUTINE 

0019 

1516 

REM 

0019 

1516 

REM 

AMBULATORY  CARE  DATA  BASE  13  APR  85 

0019 

1516 

REM 

SNIP  COLE 

***• 

0019 

1516 

REM 

•  «»« 

SUBROUTINE  NAME 

RXXS6000.SU8 

**** 

0019 

1516 

REM 

«««* 

SCANNER  PROGRAM  « 

:  ALL 

•  *** 

0019 

1516 

REM 

FUNCTION 

:  THIS  SUBROUTINE  MODULE 

**** 

0019 

1516 

REM 

«*«* 

PERFORMS  INSTRING  SEARCH 

***« 

0019 

1516 

REM 

A*-** 

•  *** 

0019 

1516 

REM 

#*•* 

INPUT 

:  STRING  TO  BE  SEARCHED  MUST 

0019 

1516 

REM 

BE  IN  THE  VARIABLE  NAMED  : 

*«** 

0019 

1516 

REN 

**** 

•XS' 

***« 

0019 

1516 

REM 

#*«• 

«*** 

0019 

1516 

REM 

**** 

OUTPUT 

:  'TOT'  =  TOTAL  NUMBER  OF 

**** 

0019 

1516 

REM 

***« 

HITS  IN  THE  DESTRING 

♦  *** 

roi9 

1516 

REM 

•HOLOSO'  IS  THE  ARRAY 

0019 

1516 

REM 

CONTAINING  THE  NUMERIC 

*•** 

0019 

1516 

REM 

VALUE  OF  THE  HIT  POSITIONS 

0019 

1516 

REH 

0019 

1516 

REM 

0019 

1516 

REN 

RESERVED  LINE 

0019 

1516 

REM 

•  «** 

NUMBERS 

:  6001-6009 

***• 

0019 

1516 

REM 

0019 

1516 

6001 

PTR  =  INSTR<XS,"1") 

0027 

1516 

TOT  =  0 

C02c 

1516 

WHILE 

PTR  >  0 

0039 

1516 

TOT-TOT+1 

0041 

1516 

HOLDSCTOT)  =  RIGHTS(STRS(PTR),2) 

00>.3 

1516 

PTR=PTR+1 

0068 

1516 

PTR  *  INSTR(PTR,X$, 

•1") 

0070 

1516 

WEND 

0031 

1516 

RETURN 

0084 

1516 

0084 

1516 

0084 

1516 

0D34 

1516 

7000 

REM  SINCLUDE:  'RACS7000.SUB 

INCLUDE  THE  SCREEN  HEADER  SUB 

0i)35 

1516 

REH 

***** 

RACP860 

IHMUMIZATION  SHORT  FORM 


PACE  1 ; 
04-24-87 


Offset 

Data 

Source  Line 

IBM  Personal  CooNXJter  BASIC  Ccmpiler  VI. 00 

0085 

1516 

REN 

*««* 

AMBULATORY  CARE  DATA 

BASE  13  APR  85 

0085 

1516 

REM 

**«• 

SKIP  COLE 

***• 

0085 

1516 

REM 

**** 

SUBROUTINE  NAME 

RACS7000.SUB 

*«*• 

0085 

1516 

REM 

*»** 

SCANNER  PROGRAM  « 

ALL 

**«« 

0085 

1516 

REM 

**•* 

FUNCTION 

THIS  SUBROUTINE  MODULE 

**** 

0085 

1516 

REM 

**** 

PRINTS  THE  STANDARD  SCREEN 

***• 

0085 

1516 

REM 

**•* 

HEADING. 

**** 

0085 

1516 

REM 

**«* 

INPUT 

COMMON  VARIABLE  USERS(2) 

**»• 

0085 

1516 

REM 

**** 

SYSTEM  DATE 

0085 

1516 

REM 

0085 

1516 

REM 

*«** 

OUTPUT 

SCREEN  HEADING 

0085 

1516 

REM 

**** 

0085 

1516 

REM 

•  **« 

RESERVED  LINE 

0085 

1516 

REM 

«•** 

NUMBERS 

7001-7010 

•*•* 

0085 

1516 

REM 

••••* 

0085 

1516 

0085 

1516 

7001 

LOCATE 

1,1 

008F 

1516 

PRINT  “U.S.  ARMY  AMBULATORY  CARE  INFORMATION  SYSTEM" 

0097 

1516 

LOCATE 

1,65 

00  A4 

1516 

PRINT  DATES; 

OOAC 

1516 

LOCATE 

2,1 

0089 

1516 

PRINT  "USER  :  ";USER$<1) 

0OC6 

1516 

RETURN 

00C9 

1516 

7100 

REM  $  INCLUDE:  'RACS7100.SU8' 

INCLUDE  THE  PRINTER  HEADER  SUB 

ODCA 

1516 

REM 

*«'***1 

ODCA 

1516 

REM 

*««« 

AMBULATORY  CARE  DATA 

BASE  13  APR  85 

OOCA 

1516 

REN 

SKIP  COLE 

ODCA 

1516 

REM 

*•«* 

SUBROUTINE  NAME 

RXXS7100.SUB 

OOCA 

1516 

REM 

*«♦* 

SCANNER  PROGRAM  « 

ALL 

•*«* 

OOCA 

1516 

REM 

*««« 

FUNCTION 

THIS  SUBROUTINE  MODULE 

ODCA 

1516 

REM 

*«** 

PRINTS  THE  STANDARD  HEADING 

*«** 

ODCA 

1516 

REM 

*«** 

ON  THE  PRINTER. 

ODCA 

1516 

REM 

INPUT 

DATE, PAGE, PGM1D$,PGMTITL$ 

OOCA 

1516 

REM 

«*** 

•*** 

OOCA 

1516 

REM 

•  *«* 

OUTPUT 

PRINTER  HEADING,  LN. COUNT 

OOCA 

1516 

REM 

*«*• 

OOCA 

1516 

REM 

RESERVED  LINE 

•••• 

ODCA 

1516 

REM 

*•** 

NUMBERS 

7101-7110 

OOCA 

1516 

REM 

ODCA 

1516 

ODCA 

1516 

7101 

IF  PAGE  >  0  THEN  LPRINT  CHR$(12); 

OOEO 

1516 

LPRINT 

"ARMY  AMBULATORY  CARE 

NFORMATION  SYSTEM....  ";PGMT1TLS; 

OOED 

1516 

LPRINT 

TA8(70);0ATE$ 

OEOO 

1516 

PAGE=PAGE+1 

0E08 

1516 

LPRINT 

"PROGRAM  " ; PGM  I  OS ; T AB ( 70 ) ; "PAGE " ; 

0E25 

1516 

LPRINT 

USING  "«###"; PAGE 

0E3I 

1516 

LPRINT 

0E39 

1516 

LN. COUNT =3 

OE40 

1516 

RETURN 

0643 

1516 

0E43 

1516 

8000 

REM  $  INCLUDE:  ■ RACS8000 . SUB ' 

INCLUDE  THE  DECODE  SUB  GROUP 

0E44 

1516 

REM 

0E44 

1516 

REM 

AMBULATORY  CARE  DATA 

BASE  13  APR  85 

*** 

0E44 

1516 

REM 

*««* 

SKIP  COLE 

[ 


UCP860 
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Offset 

Oata 

Source  Line 

IBM 

0E4A 

1516 

REM 

****  SUBROUTINE  NAME  :  RXXS8000.SUB 

•«* 

0E44 

1516 

REM 

***•  SCANNER  PROGRAM  *  :  ALL 

*«* 

0E44 

1516 

REM 

••••  FUNCTION  :  THIS  SUBROUTINE  MODULE 

•  *« 

0E44 

1516 

REM 

****  IS  A  GROUPING  THAT  PERFORMS 

•  ** 

0E44 

1516 

REM 

VARIOUS  DECODING  FUNCTIONS 

•  «« 

0E44 

1516 

REM 

ON  THE  SCANNER  OATA 

*«* 

0E44 

1516 

REM 

*•** 

*•* 

0E44 

1516 

REM 

•••*  8001  -  DECODE  THE  HEADER  POSITIONS  (POINTER  0-20) 

*'** 

0E44 

1516 

REM 

*•••  8050  -  CHECK  FOR  END  OF  JOB 

*** 

0E44 

1516 

REM 

8100  -  PRINT  THE  HEADER  DATA  ON  THE  SCREEN 

**• 

0E44 

1516 

REM 

***•  8200  -  DECODE  THE  RESPONSE  POSITIONS  (POINTER  21 

.  )  *** 

0E44 

1516 

REM 

****  (RETURNED  IN  TEXTS  STRING  VARIABLE) 

**« 

0E44 

1516 

REM 

***« 

*«* 

0E44 

1516 

REM 

*•••  INPUT  :  SHEET  RECORD,  RECORD  LENGTH 

*«* 

0E44 

1516 

REM 

•  ** 

0E44 

1516 

REM 

OUTPUT  :  'TEXTS'  THING  VARIABLE 

*** 

0E44 

1516 

REM 

**** 

**• 

0E44 

1516 

REM 

****  RESERVED  LINE 

*** 

0E44 

1516 

REM 

••••  NUMBERS  :  8001-8500 

*•* 

0E44 

1516 

REM 

*«««**«*«««******«***«*****•*#•*•«**•*«*•********««**•*****««*•«*** 

0E44 

1516 

0E44 

1516 

'DECODE  THE  HEADER  ONLT 

0E44 

1516 

8001 

POINTER  «  0 

0E48 

1516 

RECORDPTR  *  VARPTR(SHEETREC{0)) 

0E52 

1518 

FOR  J8000  «  1  TO  21 

0E59 

1518 

8002 

TEXTS*  TEXTS*CHRS(PEEK(RECOROPTR  ♦  POINTER)) 

0E77 

1518 

POIHTER=POIMTER+1 

0E7F 

1518 

NEXT  J8000 

0E3E 

151A 

PROGRAMS*  LEFTS(TEXTS,3) 

0E9D 

151E 

BATCHS*  MIDS(TEXT$,4,3) 

OEAF 

1522 

SERIALS*  MI0S(TEXTS,7,4) 

CEC1 

1526 

RUNIOS*  MID$<TEXTS,11,1) 

0E33 

152A 

FORMS*  HI0$(TEXTS,12,2) 

0EE5 

152E 

POCKETS*  MI0S(TEXT$,14,1) 

0EF7 

1532 

SCANERR1S=MIDS<TEXT$, 16,2) 

0F09 

1536 

SCANERR2S*MIDS(TEXTS,18,2) 

0F1B 

153A 

SCANERR3S*MID$(TEXTS,20,2) 

0F2D 

153E 

GOTO  8500 

0F31 

153E 

0F31 

153E 

8050 

REM  CHECK  FOR  END  OF  JOB/END  OF  BATCH 

0F32 

153E 

IF  PROGRAMS  *  PGMIDS  THEN  GOTO  8500 

0F44 

153E 

LPRINT  STRINGS(80,"*") 

OF  52 

153E 

LPRINT 

0F5A 

153E 

LPRINT  "RECORDS  PROCESSED  ...  ".-SERIALS 

TF67 

153E 

LPRINT  "STARTED  AT  .  ",-8TIME$ 

OF  74 

153E 

LPRINT  "ENDED  AT  . ".-TIMES 

0F81 

153E 

LPRINT  CHR$(12) 

0F8C 

153E 

GOTO  30000 

0r90 

153E 

0F90 

153E 

8070 

REM  CHECK  FOR  SCANNER  ERRORS 

0F91 

153E 

IF  POCKETS  =  "  "  GOTO  8500 

0FA3 

153E 

LPRINT  LITHOS; 

0FA3 

153E 

LPRINT  "  ...  SCANNER  ERRORS  : 

0Fn3 

153E 

LPRINT  SCANERR1S;"  / 

RACPe60 

IMMUNIZATION  SHORT  FORM 


Offset 

Data 

Source 

OFCO 

153E 

OFCO 

153E 

0FD5 

153E 

OFOD 

1540 

0FE1 

1540 

0FE1 

1540 

8100  1 

0FE2 

1540 

OFFC 

1540 

OFFC 

1540 

1009 

1540 

1016 

1540 

1023 

1540 

1030 

1540 

1034 

1540 

1034 

1540 

8200 

1035 

1540 

103C 

1540 

1043 

1540 

1050 

1542 

8202 

106E 

1542 

1076 

1542 

1087 

1542 

1087 

1542 

8500 

108A 

1542 

108A 

1542 

108A 

1542 

108A 

1542 

9000 

1088 

1542 

REM 

1088 

1542 

REM 

1083 

1542 

REM 

1088 

1542 

REM 

1088 

1542 

REM 

1088 

1542 

REM 

1088 

1542 

REM 

1088 

1542 

REM 

1088 

1542 

REM 

1088 

1542 

REM 

1088 

1542 

REM 

1088 

1542 

REM 

1088 

1542 

REM 

1088 

1542 

REM 

1088 

1542 

REM 

1088 

1542 

REM 

1388 

1542 

10BB 

1542 

1088 

1542 

REM 

1088 

1542 

REM 

1088 

1542 

REM 

1088 

1542 

REM 

1088 

1542 

9001 

108C 

1542 

1093 

1542 

109A 

1542 

10A1 

1542 

PACE  16 
04- '4-87 
12:51:22 

IBM  Personal  CoiiNXiter  BASIC  Conpite'-  VI. 00 


LPRIMT  SCANERRZS;"  / 
LPRINT  SCANERR3S 
LN»LN+1 
GOTO  999 


LOCATE  S,1:PRIMT  “PROGRAM  “.‘PROGRAMS; 

PRINT  “  BATCH  “.‘BATCHS; 

PRINT  “  RUN  ".‘RUNIDS; 

PRINT  "  FORM  ".‘FORMS; 

PRINT  “  POCKET  “.‘POCKETS 

GOTO  8500 

REM  OECXE  THE  RESPONSE  POSITIONS 
POINTER  »  21 

RECOROPTR  :  VARPTR(SHEETREC(0)) 

FOR  JSOOO  >  22  TO  RECOROLENGTH 

TEXTS  “  TEXTS>CHRS(PEEK(RECOROPTR  *  POINTER)) 
POINTER“POINTERr1 
NEXT  J8000 


REM 


ENO  OF  RXXS8000.SUB 


REM  SINCLUOE:  • RACS9000 . SUB '  INCLUDE  THE  SCANNER  CONTROL  SUB 


**««« 

AMBULATORY  CARE 

DATA  BASE  13  APR  85 

**** 

SKIP  COLE 

•  *** 

PROGRAM  NAME 

:  RACS9000.SUB 

***• 

SCANNER  PROGRAM 

«  ALL 

**** 

FUNCTION 

:  THIS  subroutine  MODULE 

«««* 

CONTROLS  THE  SCANNER  I/O 

**** 

**** 

**•* 

INPUT/OUTPUT 

:  REFER  TO  THE  ASYNCHRONOUS 

***• 

COMMUNICATIONS  MANUAL  AND  THE 

**«* 

PRE-RELEASED  SOFTWARE  GUIDE 

**** 

***• 

RESERVED  LINE 

**** 

NUMBERS 

;  9001-9100 

**** 

****s 

SUBROUTINE  9001  - 

PROTOCOL  SETUP  FOR  SCANNER 

**** 

ARGUMENTS:  PRESET 

...  SEE  BELOW 

REM 


PROTOCOL (0)  *  9600 
PROTOCOL(I)  =  78 
PROTOCOL (2)  =  8 
PROTOCOL{3)  =  1 


■BAUD  RATE 

'PARITY  (SEE  PAGE  4-8  OF  MANUAL) 
■DATA  BITS 
'STOP  BITS 


RACPS60 

IMMUNIZATION  SHORT  FORM 
Offset  Data  Source  Line 
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10A8 

1542 

lOAF 

1542 

10B6 

1542 

10BD 

1542 

10BO 

1542 

10C9 

1542 

1000 

1544 

10E1 

1544 

IDEA 

1544 

1106 

1544 

110A 

1544 

110A 

1544 

REM 

110A 

1544 

REM 

110A 

1544 

REM 

110a 

1544 

REM 

110A 

1544 

REM 

110A 

1544 

REM 

110A 

1544 

REM 

110A 

1544 

REM 

110a 

1544 

REM 

IIQA 

1544 

REM 

110A 

1544 

REM 

110A 

1544 

REM 

110A 

1544 

9010 

110B 

1544 

1117 

1544 

1128 

1544 

1131 

1544 

114D 

1544 

1151 

1544 

1151 

1544 

REM 

1151 

1544 

REM 

1151 

1544 

REM 

1151 

1544 

REM 

‘151 

1544 

REM 

1151 

1544 

REM 

1151 

1544 

REM 

1151 

1544 

REM 

1151 

1544 

REM 

1151 

1544 

REM 

1'51 

1544 

REM 

1151 

1544 

9020 

1152 

1544 

115E 

1544 

1165 

1544 

IITE 

1544 

187 

1544 

11A8 

1544 

iia: 

1544 

11  AC 

1544 

REM 

1  AC 

1544 

REM 

1UC 

1544 

REM 

I’^C 

1544 

REM 

1 '  AC 

1544 

REM 

PROTOCOL(4)  =  2  'RS-ZSZ  PORT 

PROTOCOL(5)  =  0  ‘WRITE  TIME-OUT 

PROTOCOL(6)  -  0  ‘READ  TIME-OUT 

ERRSTATS  s  SPACES(6Q) 

ARGPTR  »  VARPTR(PROTOCOL(0)) 

CALL  SETUP  (ARGPTR, ERRSTATS) 

ERRMSGS«"" 

IF  ASC(ERRSTATS)  <>  64  THEN  ERRHSGS:»SETUP  ERROR  ■‘-rERRSTATS 
GOTO  9100 


•••*  SUBROUTINE  9010  -  CONTROL  OPTIONS  FOR  SCANNER 

•••*  ARGUMENTS:  CNTRLOPT 

*•••  CNTRLOPT  *  1  =  START  SCANNER  (SI) 

CNTRLOPT  =  2  =  STOP  SCANNER  (SO) 

CNTRLOPT  «  3  >  TERMINATE  COMMUNICATIONS  TO  SCANNER  (DC3) 
CNTRLOPT  *  4  *  CLEAR  TRANSPORT  PATH  (DC2) 

CNTRLOPT  =  5  »  SELECT  PRIMARY  STACKER  "31“ 

••••  CNTRLOPT  =  6  »  SELECT  SECONDARY  STACKER  "32" 

CNTRLOPT  =  7  *  POSITIVE  RESPONSE/SELECT  SCANNER  (0C1) 
CNTRLOPT  =  8  s  REQUEST  STATUS  (ESC) 


ERRSTATS  =  SPACES(60) 

CALL  CNTROL  (CNTRLOPT, ERRSTATS) 

ERRMSGSs"" 

IF  ASC(ERRSTAIS)  <>  64  THEN  ERRMSGS="COHTROL  ERROR  "♦ERRSTATS 
GOTO  9100 


SUBROUTINE  9020  -  SCAN  SHEET  CALL  ***** 
«**«  ***** 

****  ARGUMENTS:  REAOTYPE  ***** 
****  REAOTYPE  =  2  =  REQUEST  NEW  DOCUMENT  FROM  SCANNER  ***** 
•***  REAOTYPE  =  3  =  RETRANSMIT  CURRENT  DOCUMENT  ***** 
****  ***** 

****  ARGUMENTS:  RECORDLENGTH  ***** 
****  NUMERIC  VARIABLE  SET  TO  THE  NUMBER  Of  CHARACTERS  TO  BE  ***** 
****  TRANSMITTED  ***** 


REM 

ERRSTATS  =  SPACES(60) 

RECORDPTR  =  VARPTR(SHEETREC(0)) 

CALL  SCAN  (REAOTYPE, RECORDLENGTH, RECORDPTR, ERRSTATS) 
ERRMSGS="" 

IF  HI0$(ERRSTAIS,14,3)  =  "415"  THEM  ERRHSG$="ESC" 
GOTO  9100 


•  *** 


***** 


RACP860  PAg:  18 
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11AC 

1544 

11AC 

1544 

11AC 

1544 

11AC 

1544 

tIAC 

1544 

11AC 

1544 

11AC 

1544 

11AC 

1544 

11AC 

1544 

HAD 

1544 

1189 

1544 

11C0 

1544 

1105 

154A 

11F1 

154  A 

11F5 

154A 

11F5 

154A 

11F8 

154A 

IIFS 

154  A 

11F8 

154A 

11F8 

154A 

IIFS 

154A 

11F9 

154A 

1201 

154A 

120E 

154A 

1212 

154A 

121E 

154A 

1222 

154A 

1234 

1S4A 

12A6 

154A 

124A 

1S4A 

124A 

154A 

124B 

154A 

124F 

154A 

1256 

154A 

125A 

154A 

1250 

154A 

REM  VALUES  =  0  THRU  90  ••••» 

REM  •••*  ••••• 

REM  ••••  ARGUMENTS:  PSTRINGS 

REM  ••••  TEXT  TO  BE  PRINTED  ON  THE  FORM  •*••• 

REM  »•••  ••••• 

REM  ***•  NOTE:  THIS  ROUTINE  HAS  NO  EFFECT  UNLESS  THE  SCAN  ••••* 

REM  HEADER  SHEET  IS  MARKED  'PRINTER  ON'  »*••* 

REM 

9030  REM 

ERRSTATS  >  SPACES(60) 

RECOROPTR  =  VARPTR<SHEETREC(0)) 

CALL  TPRINT(PRINTPOS,PSTRING$,ERRSTAT$) 

IF  ASCfERRSTATS)  <>  64  THEN  ERRMSG$=“PRIMT  ERROR  "+ERRSTAT* 
GOTO  9100 

9100  RETURN 

REM . END  OF  SUBROUTINE  RACS9000.SUB  . 

REM  END  OF  SUBROUTINES  xsxcaassxssasxsssassszsasssssssxxKxsssusxxsx&cs 

25000  REM  USER  TERMINATED  INPUT...  FILE  IS  NOT  TO  BE  USEOI 1 1 1 1 
LPRINT  "USER  TERMINATED  INPUT  ..  DATA  WILL  NOT  BE  USED!" 

LPRINT  "ERASING  FILE  ".-OATFILS 
BEEP 

CLS  :  PRINT  "USER  TERMINDATEO  INPUT  ..  DATA  WILL  NOT  BE  USED!" 

CLOSE 

OPEN  OATFILS  FOR  OUTPUT  AS  *1 

PRINT  #1,STRINC$(REC0R0LENGTH,"X")  'VOID  THE  FIRST  RECORD 
CLOSE 

30000  REM 
CLOSE 

CHAIM  "RACP10" 

END 


22151  Bytes  Available 
169S1  Bytes  Free 


0  Warning  Error(s) 
0  Severe  ErrorCs) 


offset  Data  Source  Line 
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OOIA 

0002 

REM  SLINESIZE: 

132 

001A 

0002 

REM  SPACES I ZE: 

66 

001A 

0002 

REM  STtTLE;  ■RACP900  • 

OOIA 

0002 

REM  SSUBTITLE: 

■OCC  HEALTH 

OOIA 

0002 

REM  SPACE 

RACP900 

OCC  HEALTH  FOAt*  DESTRING/DECOOE  PROGRAH 


Offset 

Data 

001A 

0002 

001A 

0002 

001A 

0002 

001A 

0002 

001A 

0002 

001A 

0002 

001A 

0002 

001A 

0002 

001A 

0002 

001A 

0002 

001A 

0002 

001A 

0002 

001A 

0002 

001A 

0002 

001A 

0002 

001A 

0002 

001A 

0002 

001 A 

0002 

001A 

0002 

001A 

0002 

001A 

0002 

001A 

0002 

001A 

0002 

0O1A 

0002 

001A 

0002 

001A 

0002 

001A 

0002 

001A 

0002 

001A 

0002 

001A 

0002 

001A 

0002 

001A 

0002 

001A 

0002 

001A 

0002 

001A 

0002 

001A 

0002 

001A 

0002 

001A 

0002 

001A 

0002 

001A 

0002 

001A 

0002 

001A 

0002 

001A 

0002 

001A 

0002 

0O1A 

0002 

001 A 

0002 

001A 

0002 

001A 

0002 

001A 

0002 

001 A 

0002 

001A 

0002 

001A 

0002 

001A 

0002 

001A 

0002 
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REM  . . . 

REM  I  NAME:  RACP900  AMBULATORY  CARE  INFORMATION  SYSTEM  | 

REM  I  DATE:  02  APR  87  OCCUPATIONAL  HEALTH  FORM  PROGRAM  | 

REM  I  D  R  BOLLING  j 

REM  . . . 

REM  OCC  HEALTH  FORM  OMR  INPUT  PROGRAM 

REM 

REM  This  proBran  reads  the  base  form  OMR  data,  converts  various 
REM  fields,  prints  an  error  report  and  produces  the  file: 

REM 

REM  VIStT.DAT 

REM 

REM  for  input  to  FOCUS.  NOTE  THAT  THIS  FILE  IS  OPENED  FOR  APPEND 
REM  each  time  the  program  is  run.  Thus,  if  the  file  does  not  exist, 

REM  records  will  be  added  to  the  front.  If  the  file  exists,  records 
REM  will  be  added  to  the  end  of  the  current  file.  It  is  intended  that 
REM  the  FOCUS  DIALOGUE  MANAGER  ROUTINE  which  toads  the  data  will  delete 
REM  the  data  file  after  the  load  has  been  successfully  accomplished. 

REM 

REM  If  there  is  no  valid  user  logged  at  the  time  of  execution,  this 
P  M  program  will  chain  to  the  logon  program  RACPOS,  otherwise, 

REM  the  program  chains  to  program  RACP10  on  exit. 

REM  SINCLUOE;  'RACOIM.MOO'  REM  INCLUDE  THE  DIMENSION  DEFINITIONS 

I ••*****•*•*••••••**♦**♦♦***♦*****••**♦****••*♦*•*♦***•**•*♦♦*♦********« 

••  NAME:  RACOIM.MOO  DIMENSION  DEFINITIONS  • 

'•  Date:  28  Feb  84  Written  by:  Floyd  Cole  • 

I **«**•****#«*♦«***♦*#********♦****#♦*»♦*•***♦#♦»***#*»*#*•***#*•***»»• 

'  Dimensioned  variables  are  defined  in  this  file. 

'  It  is  an  included  file  so  it  cannot  be  run  in  a  stand-alone, 

'  mode. 

I 

'  This  program  se^nent  may  be  axDdified,  but  all  files  containing 
'  an  include  for  this  segment  must  be  re-conpiled  in  order  to 
■  affect  the  changes  made  here. 

I  •••**•••*«••  start  OF  DIMENSION  DEFINITION  *•**•*••••••**•*••*•• 


DEFINT  A-Z 

DIM  USERSfZ) ,NOLENGTH( 12} ,0ATEERRS<3 } 

END  OF  DIMENSION  DEFINITIONS 


REM  DIMENSION  STATEMENTS  UNIQUE  TO  THIS  PROGRAM. 


DIM  SHEETREC(1750) 

DIM  PROTOCOL(7) 

DIM  YNS(3) 

DIM  E0.HSGS(30) 

DIM  CLINICI.PFXS(5) 

DIN  CLINIC2.PFXS(6) 

DIN  PROVIDER.TINES(22) 
DIM  PROCEDSdZS) 

DIM  0IAGN.TABt(22S) 


'(MAX.  SIZE  FOR  A  SHEET  FROM  THE  SCANNER) 
■(ARRAY  FOR  SERIAL  BOARD  SETUP  PARAMETERS) 
■(YES/MO  ANSWERS  0*7,  1  =  Y  ,  Z*N  ,  3*X) 
'(ERROR  MESSAGES  FROM  EDIT  ROUTINES) 
'(PREFIX  -8  D  F  C  S-  FOR  CLINIC  #1) 

■(PREFIX  -A  B  C  D  F  S-  FOR  CLINIC  *2) 
'(TIME  TABLE  FOR  PROVIDERS) 

■(PROCEDURE  TABLE  FOR  BASE  FORM) 
'(DIAGNOSIS  TABLE  FOR  BASE  FORM) 


RACP900 

OCC  HEALTH  FORM  DESTRING/DECOOE  PROGRAM 


Offstt 

0O1A 

001A 

OOU 

001A 

001A 

OOU 

OOU 

OOU 

OOU 

OOU 

OOU 

OOU 

OOU 

OOU 

OOU 

OOU 

OOU 

OOU 

OOU 

OOU 

OOU 

OOU 

OOU 

OOU 

OOU 

OOU 

OOU 

OOU 

OOU 

OOU 

OOU 

OOU 

OOU 

OOU 

OOU 

OOU 

LOU 

OOU 

OOU 

OOU 

OOU 

OOU 

OJU 

0048 

004F 

0056 

0050 

0064 

0068 

0077 

0057 

007E 

nss 

003c 
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0002 

0002 

0002 

0002 

0002 

0002 

0002 

0002 

0002 

0002 

0002 

0002 

0002 

0002 

0002 

0002 

0002 

0002 

0002 

0002 

0002 

0002 

0002 

0002 

0002 

0002 

0002 

0002 

0002 

0002 

0002 

0002 

0002 

0002 

0002 

0002 

0002 

0002 

0002 

0002 

0002 

0002 

0002 

1650 

1650 

1652 

1652 

1652 

1652 

1652 

1652 

1652 

1652 

1652 


DIM  OCCHES(20)  '(TABLE  FOR  OTHER  COOES) 

DIM  HOLOS(99)  '(HOLD  AREA  FOR  SUBROUTINE  6000) 


REM  SINCLUDE:  'RACCMN.MOO' 
**************** 


REM  INCLUDE  THE  COMMON  AREA  DEFINITION 


*  NAME:  RACCMN.MOO  COMMON  AREA  DEFINITION  • 

*  Date:  28  Feb  84  Written  by:  Floyd  Cole  * 

»**»***♦********»»****»*»»■•>•«**•>*»****»♦*****««»**«*»*»»****»***— 

COMMON  AREA  DEFINITIONS  WILL  BE  HELD  IN  THIS  FILE.  IT  IS  AN 
INCLUDED  FILE  SO  IT  CANNOT  BE  RUN  IN  A  STANO*ALONE,  MODE. 

This  prograa  segment  may  be  modified,  but  all  files  containing 
an  Include  for  this  segment  must  be  re*ccnpiled  in  order  to 
affect  the  changes  made  here. 


•••••••••••••START  OF  C0W1ON  OEFINITIONS^"^^^ 


COMMON  FORE, BACK, BOARD, HIDE, EFORE.EBACK.BELLS  'BASIC  SCREEN  COLORS 


COMMON  HEADERS 
COMMON  TEXTS 
COMMON  PGM I OS 
COMMON  MOLENGTHO 
COMMON  USERSO 

****«*****«**£^ID 


'21  CHARACTER  SCANNER  HEADER  INFO 
' •  AIRING  CHARACTERS  FROM  SCANNER 
•PROGRAM  OR  FORM  ID 
•DAYS  IN  THE  MONTH 

OF  COMMON  OEFINITION****^^^*^^^^*^^^^^**^*^^^ 


REM  SINCLUDE:  'RACOEF.MOO'  REN  INCLUDE  THE  DEFAULT  DEFINITIONS 

i******«**««*****«*«*«***********«**********«************************** 

••  NAME:  RACPOI.DEF  DEFAULT  DEFINITIONS  • 

'•  Date:  28  Feb  84  Written  by;  Floyd  Cole  • 

'  Variables  used  in  coamon  that  have  a  default  value  on  start-up 

'  will  be  held  in  this  file.  It  is  an  included  file  so  it  cannot 

'  be  run  in  a  stand-alone  mode.  In  normal  operation,  this  file 

•  should  be  'included'  in  the  main  program  only  (RACP10.BAS). 

I 

'  This  program  segment  may  be  modified,  but  all  files  containing 
'  an  include  for  this  segment  must  be  re-compiled  in  order  to 
'  affect  the  changes  made  here. 


•••••••••••••START  OF  DEFAULT  DEFINITION———' 

FORE  >  15  'FOREGROUND  COLOR  "  INTENSE  WHITE 

BACK  3  1  'Background  Color  >  Light  Blue 


BORD  3  4 

•BORDER 

1  3  RED 

HIDE  3  4 

•ALTERNATE  COLOR  ■  RED 

EFORE3  14 

•ERROR 

FOREGROUND  DISPLAY 

EBACK3  0 

•ERROR 

BACKGROUND  DISPLAY 

BELLS  ■  CHR$(7) 

'Sound  the  bell 

MOLENGTH(I)  = 

31 

•JAN 

MOLEHGTH(2)  = 

28 

•FEB  <--MOOIFIED  IN  SUBROUTINE  RACS5000.SUB 

MOLEHGTH(3) 

31 

•MAR 

MOLENGTH(4)  = 

30 

•APR 

liACP900 

OCC  HEALTH  FORM  DESTRIHG/DECCOE  PROGRAM 


Offset 

Oata 

Source  Line 

0093 

1652 

M0LENGTH(5)  >  31 

MAY 

009A 

1652 

M0LENGTH(6)  >  30 

JUN 

OOA1 

1652 

N0LENGTH(7>  =  31 

JUL 

OOAB 

1652 

M0LENGTH(8)  >  31 

AUG 

OOAF 

1652 

M0LENGTH(9)  >  30 

SEP 

OOB6 

1652 

NOLENGTH(IQ)  >  31 

OCT 

OOBO 

1652 

MOLENGTH(II)  >  30 

NOV 

00C4 

1652 

M0LENGTH(12}  >  31 

DEC 

OOCB 

1652 

OOCB 

1652 

DATEERRS(O)  *  »  » 

0004 

1652 

DATEERRS(I)  =  ■IHVALIO  MONTH* 

0000 

1652 

0ATEERRS(2)  >  •INVALID  DAY  • 

00E6 

1652 

0ATEERR$(3)  >  *OAr  TOO  LARGE 

FOR  MONTN  CODED* 

OOEF 

1652 

OOEF 

1652 

MAXLEHGTH  >  80 

•MAXIMUM  LENGTH  OF  OUTPUT  RECORD 

00F6 

1654 

PADS  « 

•PAD 

CHARACTER  FOR  SHORT  RECORDS 

OOFF 

1658 

OOFF 

1658 

1  ••>**«****.*.£md  of  default  D 

EFINITION******* ****************** 

OOFF 

1658 

OOFF 

1658 

OOFF 

1658 

KEY  OFF 

0105 

1658 

****** 

i65o 

0105 

1658 

0105 

1658 

REM  •••  default  clinic  CODE  TABLE 

0105 

1658 

CLIDEF$»"FBCA" 

01 OE 

165C 

010E 

165C 

REM  •••  CLINIC  CODE  BY  SINGLE  BUBBLE  *•* 

010E 

165C 

CL IBUSS>”BHOAFBGaBHGA" 

•OCC  HEALTH 

0117 

1660 

0117 

1660 

REM  ENCOUNTER  FORM  CLINIC  PREFIX  TABLE 

0117 

1660 

REM  CLINIC  *1 

CLINIC  «2 

0117 

1660 

CLIHIC1.PFXS(0)="  " 

CLIHIC2.PFX${0)**  " 

0129 

1660 

CLINIC1.PFX$(1)="S" 

CLINIC2.PFX${1)*"A" 

013B 

1660 

CLINIC1.PFX$(2)="0" 

CLINIC2.PFX»(2)="B" 

0140 

1660 

CLINIC1.PFX$<3)="F" 

CLIHIC2.PFX${3)="C" 

015F 

1660 

CLINIC1.PFX$(4)»"G" 

CLINIC2.PFX$<4)="0" 

0171 

1660 

CLINIC1.PFX$<5)="S" 

CLIHIC2.PFXS{5)="F" 

0183 

1660 

CLINIC2.PFX*<6)»"S" 

018C 

1660 

018C 

1660 

REM  •**  ENCOUNTER  FORM  PROVIDER 

TIME  TABLE  ••• 

018C 

1660 

018C 

1660 

PROVIDER. TIMES(00)s*000* 

•  NO  TIME 

0195 

1660 

PROVIDER. TIMES(01  ):"002<' 

•  2  MINUTES 

019E 

1660 

PROVIDER. TIHE${02)*"005" 

•  5  MINUTES 

01A7 

1660 

PROVIDER. TIM£$(03)="010" 

•  10  MINUTES 

0180 

1660 

PROVIDER. TIMEt(04)="015* 

•  15  MINUTES 

01B9 

1660 

PROVIDER. TIME$(05)>*020" 

•  20  MINUTES 

01 C2 

1660 

PROVIDER . T I ME$( 06) s*030" 

•  30  MINUTES 

01C8 

1660 

PROVIDER . TIHE$(07)**045“ 

•  45  MINUTES 

0104 

1660 

PROVIDER. TIMES{08)»"060" 

•  1  HOUR 

0100 

1660 

PROV IDER . T I ME$< 09) *"090" 

•  1  HOURS/30  MINUTES 

0IE6 

1660 

PROVIDER. TIME$<10)*"120" 

■  2  HOURS 

01EF 

1660 

PROVIDER . TIMEt( 1 1 )="150" 

•  2  HOURS/30  MINUTES 

PAG'  4 
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Offset 

01 F8 
0201 
020A 
0213 
021 C 
022S 
022E 
0237 
0240 
0249 
0252 
025B 
025B 
025B 
027F 
027F 
027F 
027F 
0291 
02A3 
02BS 
02C7 
0209 
02EB 
02  FD 
030F 
0321 
0333 
C333 
0333 
0345 
0345 
034C 
0353 
035E 
035E 
0365 
036C 
036C 
0375 
037E 
037E 
037E 
138C 
0390 
03A3 
03BB 
0307 
0356 
03ED 
03ED 
03ED 
03'B 
04  OC 
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1660 

1660 

1660 

1660 

1660 

1660 

1660 

1660 

1660 

1660 

1660 

1660 

1660 

1660 

1660 

1660 

1660 

1660 

1660 

1660 

1660 

1660 

1660 

1660 

1660 

1660 

1660 

1660 

1660 

1660 

1662 

1662 

1664 

1666 

1668 

1668 

166A 

166C 

166C 

1670 

1674 

1674 

1674 

1678 

1678 

1678 

167A 

167A 

167A 

167A 

167A 

167a 

167A 

167a 


PROVIDER. TIMESdEIxxiSO" 
PROVIDER. TIMESdSI^oElO* 
PROVIDER. TIMESdAI-oEAO" 
PROVIDER.TIHE$d5)»“270“ 
PROVIDER. TIME$d6)>‘‘300* 
PROVIDER.TIME$d7)»"330“ 
PROVlDER.TIMESd8)»“360" 
PROVIDER .T IME$< 19)»“390“ 
PROVIDER  .T  IHES(20)-'*420'‘ 
PROVIDER. TIMES(21 )»«450« 
PROVIDER.  TIMES(22)>"480‘‘ 

REM  YES/HO  TABLE 

YNS(0)«"  ■  :  YHSd)*“Y 

REM  **•  TABLE  OF  OTHER  COOES 


3  HOURS 

3  HaURS/30  MINUTES 

4  HOURS 

4  HOMS/ZO  MINUTES 

5  HOURS 

5  HaURS/30  MINUTES 

6  HOURS 

6  HOURS/30  MINUTES 

7  HOURS 

7  HOURS/30  MINUTES 

8  HOURS 


YH$(2)«"N"  :  YN$(3)*"X“ 

*•* 


OCCHES(01)>«01002" 

OCCHES(02)="01003« 

OCCHESIOSTaMOIOOA" 

OCCHES(04)s»0I005" 

OCCHES<0S)«'<01006‘' 

OCCHE$<06)»“01007” 

OCCHE$<07)»«01008" 

OCCHE$(08)»"01009" 

OCCHE$<09)««01010" 

OCCHE$d0)="O101V' 


OCCH£$d1)«"01012*‘ 

0CCH£Sd2)*“01013** 

OCCHE$d3)=*01014“ 

OCCHE$d4)=«Q1015“ 

OCCHE$d5)="01016'' 

0CCHESd6)»"01017" 

OCCHESd7)»”01018" 

OCCHESd8)«“01019» 

OCCHESd9)»"01020" 

OCCHE$(20)=”01021" 


*************************************************************** 

PHUM=VAL<PGMI0S)/10 

REM  LENGTH  OF  STRING  RECEIVED  FROM  THE  OMR.... 

HEADER  ■  21 
RESPONSE*  513 

RECORDLENGTH  *  HEADER  *  RESPONSE 

N.PROC  *  81  <  NUMBER  OF  PROCEDURES  FOR  THIS  FORM 

N.DIAG.COL*4  '  NUMBER  OF  DX  COLUMNS  OH  THIS  FORM 

DATFILS  *  "VISIT.DAT"  'FILE  TO  BE  INPUT  TO  FOCUS 
BTINE$*TIHES  'SCAN  START  TIME 

REM  ENCOUNTER  FORM  PROCEDURE  TABLE  ••• 

F.NAME$="RACPROC."  +  PGMIDS 
OPEN  F. NAMES  FOR  INPUT  AS  #3 
FOR  1600=0  TO  125 

INPUT  1*3, PROCEOSf  1600) 

IF  PROCEDS(I600)=«22ZZZ''  THEN  GOTO  4 
NEXT  1600 
4  CLOSE  #3 

REM  ENCOUNTER  FORM  DIAGNOSIS  TABLE  *•* 

F.NAHES="RACOIAG."  *  PGM I OS 
OPEN  F. NAMES  FOR  INPUT  AS  « 

FOR  1600  =  0  TO  225 


RACP900 
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OfFset 

Oata 

Source  Line 

0412 

167A 

INPUT  *3,DIAGN.TAB$(I600) 

042A 

167A 

IF  0IAGN.TAB$(I600)»"ZZZZZ«  THEN  GOTO  6 

0444 

167A 

NEXT  1600 

0456 

167A 

6 

CLOSE  #3 

0450 

167A 

0450 

167A 

REM 

INCLUDE: 

•UCACAMP.OPT'  INCLUDE  THE  OUTP  UCA  VALIDATE  TABLI 

0450 

167A 

REM 

INCLUDE: 

'UCACAMP.IPT*  INCLUDE  THE  INP  UCA  VALIDATE  TABLE 

0450 

167A 

0450 

167A 

REM  SPAGE 

PAGE  A 
07-06-?7 
15:07:00 

IBM  Personal  Computer  BASIC  Compiler  vl.''0 
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Offaet 

Data 

045D 

167A 

0A62 

167A 

0A66 

167A 

046B 

167A 

0A6B 

167A 

046B 

167A 

0468 

167A 

046B 

167A 

046B 

167A 

047D 

167A 

047D 

167A 

0470 

167A 

0470 

167A 

0470 

167A 

0488 

167A 

0492 

167A 

049E 

167C 

04AS 

167C 

04aA 

167C 

0400 

167C 

0400 

167C 

0400 

167C 

0400 

167C 

0400 

167C 

0400 

167C 

0405 

167C 

04EF 

1680 

04EF 

1680 

04£F 

1680 

04FB 

1682 

0515 

1682 

0515 

1682 

052A 

1682 

0531 

1684 

0531 

1684 

0531 

1684 

0531 

1684 

1531 

1684 

0531 

1684 

0531 

1684 

0532 

1684 

0532 

1684 

0S3B 

1688 

0551 

1688 

0551 

1688 

0556 

1688 

0572 

168C 

0572 

168C 

057B 

168C 

0580 

168C 

0'.;85 

168C 

058A 

168C 

059C 

1690 

05A1 

1690 
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07-06-87 
15:02:00 

Source  Line  IBM  Personal  Computer  BASIC  Lompiter  V1.00 

GOSUB  1000  'MAKE  SURE  THEY  ARE  LOGGED  ON 

CLS 

GOSUB  7000  'PRINT  SCREEN  HEADING 


REM  ****  OPEN  FILE  TO  CONTAIN  SCANNED  DATA 

****e*e**e»**»»»**»»*a»»»*»***»»»**»a»*e*****>«**»****»**»*i 

REM 

OPEN  DATFILS  FOR  APPENO  AS  «1 


REM  ****  CLEAR  AND  DISPLAY  PROGRAM  SCREEN 

LPRINT  CHRS(IS); 

WIDTH  ••LPT1:",160 

PAGE  •  0  :  GOSUB  7100  'I  INE  PRINTER  HEADING 
COLOR  U 

LOCATE  11,26  :  PRINT  "BASE  ENCOUNTER  FORM  " 

COLOR  FORE, BACK, BORO 


p£f|f  A****************************************************************** 

REM  •••*  COMMUNICATIONS  SETUP  ***• 

Hg/if  ******************************************************************* 

REM  PROTOCOL 

GOSUB  9001 

IF  ERRMSGS  >  "  *  THEN  LPRINT  ERRMSGS  :  GOTO  30000 


REM  START  SCANNER  (SI) 

CNTRLOPT  *  1  .-GOSUB  9010 

IF  ERRMSGS  >  "  "  THEN  LPRINT  ERRMSGS  :  GOTO  30000 

LOCATE  22,25;PRIHT  "PRESS  'ESC  TO  TERMINATE  SCANNING  " 
REAOTYPE=3  'FIRST  TIME  IN..  SCAMMER  IS  STARTED.. 


REM  *•**••*••••****•»*••••*•*•*••••*••••»••*’ 

REM  **•  SET  SCAM  SHEET  CALL 

REM 

REM 

10  REM  -  RETURN  POINT  TO  READ  NEXT  SHEET 


AS= INKEYS 

IF  AS:CHRS(27)  THEN  GOTO  25000 

GOSUB  9020  'SCAN  SUBROUTINE  •  GET  A  RECORD 

IF  MIDS(ERRSTATS,1«,3)="A15"  THEN  GOTO  25000 

TEXTS=""  'CLEAR  THE  INPUT  AREA 

GOSUB  8000  'DECODE  HEADER 

GOSUB  8050  'CHECK  FOR  END  OF  JOB/END  OF  BATCH 

GOSUB  8200  'DECODE  THE  RESPONSE  POSITIONS 

LITHOS  *  HIDS(TEXTS,22,8) 

COSUB  8070  'CHECK  FOR  SCANNER  ERRORS 

GOSUB  8100  'PRINT  THE  DATA  ON  THE  SCREEN 


Y 
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05A6 

1690 

0SA6 

1690 

REM  SINCLUDE;  •RACM900.HOV  INCLUDE  THE  READ  FORM  REFORMAT/EDIT  MOO 

0SA6 

1690 

REM 

05  A6 

1690 

REM 

****  AMBULATORY  CARE  IHFORMATION  SYSTEM 

20  MAY  87  •••• 

0SA6 

1690 

REM 

***• 

0  R  BOLLING 

0SA6 

1690 

REM 

MODULE  HAME  RACM900.M01 

•••« 

05A6 

1690 

REM 

****  SCANNER  PROGRAM  «  :  GENERAL 

FORM 

0SA6 

1690 

REM 

***« 

***« 

05A6 

1690 

REM 

••••  PURPOSE  :  REFORMAT/EOIT  THE  FORM  •«* 

05A6 

1690 

REM 

05A6 

1690 

REM 

*««****««•*•••***«*««•*«««*»«•***«*****«**•****«**«•**«**«*****«*** 

05A6 

fl^AA 

1690 

1XOA 

REM 

ACB8 

••••  RESERVED  LIME  NUMBERS  100-199 

w3AO 

0SA6 

iOtv 

1690 

Rcff 

0SA6 

1690 

N.ERR  >=0  ’COUNTS  THE  NUMBER  OF 

ERRORS 

OSAO 

1692 

OSAD 

1692 

REM 

•••  LITHO  CODE  DONE  IN  BAS  PROGRAM  **• 

OSAO 

1692 

OSAD 

1692 

REM 

***  CLINIC  ID  (PREFIX  ♦  CODE)  •** 

OSAO 

1692 

100 

CL1.CQ0$>CLIDEFS  ’DEFAULT  CLINIC  CODE 

05B6 

1696 

0SB6 

1696 

REM 

...  CLINIC  CODE  WHEN  SINGLE  BUeBLEO  ... 

0SB6 

1696 

IF  MI0$(TEXTS,34,1)»>'  «  THEN  102 

OSCE 

1696 

X3VAL(MI0S(TEXT$,34,1)) 

0SE4 

1698 

X*(X-1)*4»1  ’CALCULATE  OFFSET 

0SF4 

1698 

CL1  .COOS^ID$(CLIBU8S,X,4) 

0607 

1698 

GOTO  104 

060B 

1698 

0608 

1698 

REM 

...  CLINIC  CODE  WHEN  HAND  COOED  ... 

0608 

1698 

102 

IF  MID$(TEXT$,30,4)«"  ■  THEM  104 

0623 

1698 

CK.X>VAL(HI0S(TEXT$,30,1}) 

0639 

169A 

CK.C00$=MI0S<TEXT$,31 ,3) 

064B 

169E 

REM 

GOSUB  5500  ’OUTP  UCA  CODE  CHECK 

064B 

169E 

REM 

IF  RT.5500  0  THEN  GOTO  102 

064B 

169E 

REM 

N.ERR  •  N.ERR  *  1 

064B 

169E 

REM 

ED.MSGS(N.ERR)="INVALIO  CLINIC  CODE" 

064B 

169E 

064B 

169E 

CL1.CQO»>CLINIC1.PFXS<CK.X)  +  CK.CODS  ’HAND 

COOED 

0663 

169E 

0663 

169E 

REM 

VISIT  DATE 

0663 

169E 

104 

CM$<MIOS(DATES,1,2)  ’CURRENT  MONTH 

0675 

16A2 

YR$»MID$(DATES,9,2)  ’CURRENT  YEAR 

0687 

16A6 

XS°MIDS(TEXT$,3S,4)  ’MONTH  AND  OAT 

0699 

16AA 

IF  LEFT$(XS,2)<»CM$  THEM  105  ’OK,  USE  THIS  YEAR 

06AE 

16AA 

YRS*HIGHT${STRS(VAL{YR$)-1),2)  'USE  LAST  YEAR 

06CE 

16AA 

105 

VIDATE$*YR$+X$ 

060C 

16AE 

01$=MID$(X$,3,1) 

06EE 

1682 

D2$-HID$(XS,4,1) 

0700 

1686 

IF  01$*"  ■  AND  D2$<>'’  "  THEN  RT. 5000*2  :  GOTO 

106 

072E 

1688 

IF  01$<>"  "  AND  D2$*«  "  THEM  RT. 5000=2  ;  GOTO 

106 

075C 

1688 

■EDIT  VISIT  DATE 

07SC 

1688 

CK.SOOO$*VIDATES 

0765 

16BC 

COSUB  5000  ’DATE  CHECK 

076A 

16BC 

IF  RT. 5000*0  THEN  GOTO  107 

1. 
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Offset 

Oats 

Source  Line 

0779 

i6ac 

106 

N.ERR>N.ERR+1 

0781 

16BC 

ED.MSG$(H.ERR)**VISIT  DATE*  «  DATEERRSTRT.SOOO) 

07A7 

168C 

07a7 

i6ac 

REM 

•**  PRIMARY  PROVIDER 

07A7 

168C 

107 

PPROV.PFXS«MIDS(TEXTS,39,1) 

0789 

16C0 

PPR0V.MUH$^IDS(TEXTS,40,4) 

07CB 

16C4 

07CB 

16C4 

REM 

•••  PATIEHT  SSH 

07CB 

16C4 

108 

SSNS  ■  Mt0$(TEXTS,44,9) 

07D0 

16C8 

0700 

16C8 

REM 

FAMILY  MEMBER  PREF  **• 

0700 

16C8 

110 

FMEMPS>MI0$(TEXT$,S3,2} 

07EF 

16CC 

07EF 

16CC 

REM 

FORM  HUMBER  **• 

07EF 

16CC 

FRMN$3LEFTS(PGMIDS,2) 

07FE 

1600 

07FE 

1600 

REM 

VISIT  COUNT  ••• 

07FE 

1600 

VCHT»«“1»  'DEFAULT 

0807 

1604 

0807 

1604 

REM 

**•  JOB  REL  IF  YES 

0807 

1604 

J08R I FS^  1 0$(  TEXTS,  55 , 1 ) 

0819 

1608 

JOBRtFSa"M" 

0822 

1608 

IF  MIOS<T£XrS,55.1>»"l"  THEN  J0BRIF$a«1“ 

oenz 

1608 

IF  MI0$(TEXT$,55,1)«"2*  THEN  J08RIFS»"2" 

0864 

1608 

IF  MIDS(TEXT$,S5,1)»"3"  THEN  J0BRIFS*"3" 

0885 

1608 

0885 

1608 

REM 

PRIMARY  PROVIDER  TIME 

0885 

1608 

114 

X=VAL(MID$<TEXT$,56,2)) 

089B 

1608 

PPROV.TIMS=PROVIDER.TIME$(X) 

OSAO 

160C 

OSAO 

160C 

REM 

SECONDARY  PROVIDER  ••• 

08A0 

160C 

115 

SPROV . PFX$=M I DSC  TEXTS ,58,1) 

08BF 

16E0 

SPROV . NUHS>M I 0S( TEXTS ,59,4) 

0801 

16E4 

IF  SPROV.NUMSs”  "  THEN  P8=1  ELSE  P8=0  'PROV  2  BLANX 

08F0 

16E6 

IF  SPROV.PFXS="  «  AND  SPROV.NUMSo*  ■  THEN  116 

0916 

16E6 

IF  SPROV.PFXSo"  *  AND  SPROV.NUM$="  ■  THEN  116 

093C 

16E6 

GOTO  117 

0940 

16E6 

0940 

16E6 

116 

N.ERR  =  N.ERR  +1 

0948 

16E6 

ED.MSGS(N.ERR)="PROV  2  CODE  MISSING  PREFIX  OR  NUMBER" 

095C 

16E6 

095C 

16E6 

REM 

**•  SECONDARY  PROVIDER  TIME  ••• 

95C 

16E6 

117 

X=VAL(MI0S(TEXTS,63,2)) 

0972 

16E6 

SPROV . T I MS^PROV I DER . T I MES( X ) 

0984 

16EA 

REM  IS  THERE  A  TIME  AND  NO  SEC  PROV  COOE07 

0984 

16EA 

IF  SPROV. TIMS<>"000"  AND  PB*1  THEN  118 

0947 

16EA 

REM  IS  THERE  NO  TIME  AND  A  SEC  PROV  COOED? 

u9F7 

16EA 

IF  SPROV. TIM$="000"  AND  PB=0  THEN  119 

09CA 

16EA 

GOTO  120 

09CE 

16EA 

09CE 

16EA 

118 

N.ERR  *  N.ERR  >1 

0904 

16EA 

ED.MSGS(M.ERR)="TIME  COOED  WITH  MO  SEC  PROV  COOED" 

09EA 

16EA 

GOTO  120 

09EE 

16EA 
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Offset 

Data 

Source  Line 

09EE 

16EA 

119 

H.ERR  3  n.ERR  +1 

09F6 

16EA 

EO.MSG$(M.ERR)*"HO  PROV  2  TIME" 

OAOA 

16EA 

OAOA 

16EA 

REM 

•••  REASON  FOR  SECONOARY  PROVIOER  **• 

OAOA 

16EA 

120 

SPROV . REA$=M I0$(TEXT$,65,1) 

0A1C 

16EE 

REM  IS  THERE  A  REASON  ANO  NO  SEC  PROV  CODED? 

0A1C 

16EE 

IF  SPROV. REASo"  "  AND  PB«1  THEN  121 

0A3F 

16EE 

REM  IS  THERE  NO  REASON  ANO  A  SEC  PROV  COOED? 

0A3F 

16EE 

IF  SPROV. REA$=“  "  ANO  PB"0  THEN  122 

0A62 

16EE 

GOTO  123 

0A66 

16EE 

0A66 

16EE 

121 

N.ERR  >  N.ERR  +1 

0A6E 

16EE 

ED.MSGS<N.ERR)="REASON  COOED  WITH  NO  SEC  PROV  COOED" 

0A82 

16EE 

GOTO  123 

0A86 

16EE 

0A86 

16EE 

122 

N.ERR  >  N.ERR  +1 

0A8E 

t6EE 

EO.MSG$<N.ERR)="NO  PROV  2  REASON" 

0AA2 

16EE 

0AA2 

16EE 

REM 

•••  IF  NOT  SCHEDULED 

0AA2 

16EC 

123 

X«VAL(MIO$< TEXTS, 66,1)) 

OABA 

16EE 

NOTSCS»RIGHT$<STR$<X*1),1)  'DEFAULT  IS  1 

OACC 

16F2 

OACC 

16F2 

REM 

IF  NOT  CLINIC 

OACC 

16F2 

124 

X*VAL<MI0$<TEXT$,67,1)) 

0AE2 

18F2 

NOTCLS»HIGMTS(STR$(X+1),1)  'DEFAULT  IS  1 

0AF6 

16F6 

0AF6 

16F6 

REM 

REFERRAL  CODE  ••• 

0AF6 

16F6 

REF.PFX$="  " 

OAFF 

16FA 

REF. COOS""  ■ 

OB08 

16FE 

0B08 

16FE 

REM 

**•  ILLNESS  ••• 

OBOfi 

16FE 

126 

ILLNS=MI0S<TEXTS,68,1) 

0B1A 

1702 

IF  ILLN$«"1"  THEN  ILLN$«"N" 

0B31 

1702 

IF  ILLNS="2"  THEM  ILLNS""R" 

0B48 

1702 

0BA8 

1702 

REN 

•**  INJURY  ••• 

0848 

1702 

128 

INJUS"HIDS(TEXTS,69,1) 

0B5A 

1706 

IF  INJUS>"1"  THEN  INJUS""N« 

0B71 

1706 

IF  INJUS="2"  THEN  INJUS="R" 

0888 

1706 

0888 

1706 

REM 

•**  PURPOSE  OF  VISIT 

0888 

1706 

PURPS=MIDS{TEXTS,70, 1 ) 

0B9A 

170A 

REM 

CONVERT  ALPH  INTO  NUM 

089A 

170A 

PURPV»ASC(PURPS)-64 

08A7 

170C 

IF  PURPS""  “  THEN  PURPV"0 

OBBC 

170C 

088C 

170C 

REN 

JOB  RELATED  VISIT  ••• 

088C 

170C 

130 

RELAT.VISS="N" 

OBCS 

1710 

OBCS 

1710 

REM 

***  MIL  ONLY  DUTY  ••• 

08CS 

1710 

132 

NILDUTS"MIDS<TEXTS,72,1) 

0807 

1714 

0807 

1714 

REM 

•**  MIL  ONLY  OTRS 

0BO7 

1714 

134 

MIL0TRS=MIDS(TEXTS,73,1) 

PACE  10 
07-06-e7 
15:02  00 

IBM  Personal  Coinputer  BASIC  Conpile,  wl.OO 
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Offset 

Data 

Source 

i3;uc;uu 

Line  IBM  Personal  Coiqauter  HASIC  Conpiter  VI. 00 

0BE9 

1718 

0BE9 

1718 

REM 

MIL  OMLY  PROF  •*» 

08E9 

1718 

136 

NILPROS^10S(TEXTS,74. 1 ) 

08FB 

I7tC 

OBFB 

171C 

REM 

HOT  AVAILABLE 

OBFB 

171C 

138 

NAVAI  LS^IOSCTEXTS.  75 , 1 ) 

OCOO 

1720 

OCOD 

1720 

REM 

SPEC  PREASSIGMEO  CLIHIC  *•* 

OCOO 

1720 

140 

IMP. STOSsMIO$(TEXTS, 80,12)  ‘INCLUDE  NOT  AVAILABLE  BUBBLES 

0C1F 

1724 

GOSUB  5700  ‘CONVERT  ARRAY 

0C24 

1724 

SPE.BUFS^BUF.STOS  ‘UP  TO  9  TWO  DIGIT  COOES 

0C2O 

172C 

0C2O 

172C 

REM 

•••  SPEC  PROGRAMS  **• 

OC20 

172C 

REM 

READ  AS  ARRAY  **• 

0C2D 

172C 

142 

SRPROGS**  “ 

0C36 

1730 

0C36 

1730 

REM 

**•  PROVIDER  2  AOOL  PROC  1  ••• 

0C36 

1730 

144 

PR2PRC1S»“N‘* 

0C3F 

1734 

IF  MI0$<TEXTS,92,1)«‘‘1‘‘  THEN  PR2PRC1$»“Y‘‘ 

0C60 

1734 

IF  MI0${TEXTS,92,1)*‘‘2"  THEN  PR2PHC1$«“3‘* 

ocai 

1734 

0C81 

1734 

REM 

ADDITIONAL  PROCEDURE  1  **• 

0C81 

1734 

146 

AD0P1$*MIDS{TEXTS,93,5) 

0C93 

1738 

IF  PR2PRC1S»"Y“  AND  PB»1  THEM  147 

0CB6 

1738 

GOTO  148 

0C8A 

1738 

OCBA 

1738 

147 

N.ERR  s  N.ERR  *  1 

0CC2 

1738 

ED.MSG$(H.ERR)='‘AOOL  PROC  COTEO  FOR  PROV  2  BUT  PROV  2  MOT  COOED" 

0C06 

1738 

DC06 

1738 

REN 

•••  PROVIDER  2  ADOL  PROC  2  *•* 

OC06 

1738 

148 

PR2PRC2Sa‘‘N" 

OCOF 

173C 

IF  HI0SaEXTS,98,1)*‘‘1"  THEN  PR2PRC2S»"Y“ 

0000 

173C 

IF  MIDS(TEXTS,98,1)="2"  THEN  PR2PRC2S="3" 

C021 

173C 

0021 

173C 

REM 

•••  ADDITIONAL  PROCEDURE  2  •••• 

0021 

173C 

150 

A0DP2$«MID$(TEXT$,99,5) 

0C33 

1740 

IF  PR2PRC2$='‘Y‘‘  AND  PBal  THEM  151 

0056 

1740 

GOTO  152 

OOSA 

1740 

C«A 

1740 

151 

N.ERR  ■  N.ERR  *  1 

0062 

1740 

ED.HSGS(N.ERR)’:"A00L  PROC  COOED  FOR  PROV  2  BUT  PROV  2  NOT  COOED" 

0076 

1740 

0076 

1740 

REM 

**•  ADMITTED 

0076 

1740 

152 

A0MIT$="N" 

007F 

1744 

IF  MI0$(TEXT$,104,1)»"1"  THEN  ADMITS»"Y" 

TOAO 

1744 

OOAO 

1744 

REM 

**•  UNLISTED  PRIMARY  OX  ••• 

OOAO 

1744 

154 

X»VAL  <N 1 0S{ TEXTS , 1 05 , 1 ) ) 

0DB6 

1744 

IF  X=0  THEM  PRIMDXt*"" 

C1CA 

1748 

IF  X*1  THEN  PRIMOX$='‘V'‘ 

CODE 

1748 

If  X=2  THEN  PRIHDXt="S'‘ 

OOF2 

1748 

DXTMPSsMIDS(TEXT$, 106,5) 

OF. .4 

174C 

IF  DXTMPS="  "  THEM  GOTO  158 

OF  16 

174C 

I 
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Offset 

Data 

Source  Line 

0E16 

174C 

REM  REMOVE  LEADING  BLANKS 

0E16 

174C 

156 

IF  LEFT$<0XTMPS,1)»"  "  THEN  0XTMP$=RIGHT$(DXT(«^,4)-»“  «:GOTO  156 

0E45 

174C 

0E45 

174C 

158 

LA$TCS=RIGHTS(DXTMPS,1)  'GET  UST  CHAR 

0E54 

1750 

IF 

LASTCSo"  AND  LASTC$<>''0"  THEN  PRIMOXS*"**  ‘REMOVE  V  OR  S 

OE80 

1750 

PRIMDXS«LEFTS(PRIM0XS^XTMPS.5)  'GET  5  CHAR  ONLY 

0E92 

1750 

0E92 

1750 

REM 

UNLISTED  secondary  OX 

0E92 

1750 

160 

XaVAL(NID$(TEXTS, 111,1)) 

0EA8 

1750 

IF  X*0  THEM  SECOXt»““ 

OEBC 

1754 

IF  X»1  THEM  SECOXS«"V" 

OEOO 

1754 

IF  X*2  THEN  SECOXM-S" 

0EE4 

1754 

DXTMPS«MI0$(TEXTS,112,5) 

0EF6 

1754 

IF  0XTMPS>x  «  THEN  GOTO  164 

0F06 

1754 

OF08 

1754 

REM  REMOVE  LEADING  BUNKS 

0F08 

1754 

162 

IF  LEFTS(OXTMPS,1)*«  THEN  0XTHPS>RIGHTS(DXTMPS,4)«'*  ••:GOTO  162 

0F37 

1754 

0F37 

1754 

164 

USTCS<RtGHTS(0XTMPS,1)  ‘GET  UST  CHAR 

0F46 

1754 

IF 

LASTCSo"  "  AND  LASTC$o»0«  THEN  SEC0XS=“*  'REMOVE  V  OR  S 

0F72 

1754 

UCOXS^LEFTSCSECOXS-KIXTMPS.S)  'GET  5  CHAR  ONLY 

0F84 

1754 

0F84 

1754 

REM 

FOLLOW  UP/RULE  OUT  ••• 

0F84 

1754 

166 

FU.ROS«MtOS( TEXTS, 117,1} 

0F96 

1758 

0F96 

1758 

REM 

•*»  EVALUATION/SERV/PROC  PROV  1 

0F96 

1758 

168 

INP.STOS<MIOt(TEXTS,118,N.PROC) 

0FA9 

1758 

ESP.BUFIS*"" 

0FB2 

175C 

N.STO>1 

0FB9 

175E 

0FB9 

175E 

169 

X.STO»INSTR(N.STO,INP.STOS,"1") 

OFCB 

1760 

IF  X.STO*0  THEN  GOTO  170  'THATS  ALL 

OFOA 

1760 

N.STO»X.STO  ♦  1  'NEXT  STARTING  POINT 

0FE2 

1760 

ESP.BUFIS^ESP.BUFIS  *  PROCEOSlX.STO)  'AOD  CODE  TO  BUFFER  BY 

0FF7 

1760 

IF  N.STO  <s  LEN(INP.STOS)  THEN  GOTO  169 

100A 

1760 

100A 

1760 

REM 

EVALUATION/SERV/PROC  PROV  2 

100A 

1760 

170 

INP.STOS=MIO$<TEXT$,118*N.PROC,N.PROC) 

1021 

1760 

ESP.SUF2S-'"' 

102A 

1764 

N.STO>1 

1031 

1764 

1031 

1764 

171 

X.STO»IMSTR(M.STO,INP.STOS,"1") 

1043 

1764 

IF  X.STO=0  THEN  GOTO  174  'THATS  ALL 

1052 

1764 

IF  PB>1  THEN  172 

1050 

1764 

N.STO«X.STO  ♦  1  'NEXT  STARTING  POINT 

106S 

1764 

ESP.BUF2S:ESP.SUF2S  4-  PROCEOS(X.STO)  'AOO  CODE  TO  BUFFER  BY 

107A 

1764 

IF  N.STO  <»  LENdNP.STOS)  THEN  GOTO  171 

loao 

1764 

GOTO  174 

1091 

1764 

1091 

1764 

172 

N.ERR  <  N.ERR  *  1 

1099 

1764 

E0.HSGS(N.ERR)°''PROC  COOED  FOR  PROV  2  BUT  PROV  2  NOT  COOED" 

10AO 

1764 

10AO 

1764 

REM 

•••  EVALUATION/SERV/PROC  OUT  **• 

10AO 

1764 

174 

IMP. STOS=M IDt(TEXTS,118»2*N. PROC , N . PROC ) 

PAGE  12 
07-06-  87 
15.02:00 
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Offset 

Oats 

Source  line  Personal  Computer  BASIC  Confiiler  vl.OO 

10C9 

1764 

ESP.BUF3$»"" 

1002 

1768 

M.STC=1 

1009 

1768 

1009 

1768 

175 

X.STO«INSTR(M.STO.INP.STO$,«1“) 

10EB 

1768 

IF  X.STO»0  THEM  GOTO  176  'THATS  ALL 

10FA 

1768 

M.STO»X.STO  ♦  1  ‘NEXT  STARTING  POINT 

1102 

1768 

ESP.BUF3»»ESP.BOF31  +  PROCEDKX.STO)  'ADO  CODE  TO  BUFFER  BY  FIVES 

1117 

1768 

IF  N.STO  <-  LEN(INP.STOt)  THEN  GOTO  175 

112A 

1768 

112A 

1768 

176 

T.POS  »  118  ♦  3*N.PROC 

1138 

176A 

1138 

176A 

OTHN  >  20  ‘NUMBER  OF  OTHER  COOES 

113F 

176C 

113F 

176C 

REM 

*•*  OTHER  COOES 

113F 

176C 

178 

I HP . ST01=M10$( TEXTS , T . POS , OTHN ) 

1153 

176C 

OTH.BUFt*"" 

115C 

1770 

N.STO>1 

1163 

1770 

1163 

1770 

ISO 

X.STO»INSTR(N.STO,INP.STO$,"1") 

1175 

1770 

IF  X.STO*0  THEM  GOTO  182  'THATS  ALL 

1184 

1770 

N.STO»X.STO  ♦  1  'NEXT  STARTING  POINT 

118C 

1770 

OTH.aUFS»OTH.BUFS  ♦  OCCHESIX.STO)  'ADD  CODE  TO  BUFFER  BY  FIVES 

llAl 

1770 

IF  N.STO  <•  LENdNP.STOS)  THEN  GOTO  180 

11B4 

1770 

11B4 

1770 

182 

T.POS  «  T.POS  ♦  OTHN 

11BF 

1770 

184 

REN 

11C0 

1770 

ilCO 

1770 

REM 

PRIMARY  OX  *•* 

11C0 

1770 

REM 

*  IF  OTHER  PRIM  OX  IS  COOED  THEN  SKIP  THIS  SECTION  • 

11C0 

1770 

186 

IF  PRIMOXSO"  ”  then  GOTO  191 

1102 

1770 

X.POS*T.POS  'STARTING  POSITION 

•,109 

1772 

C13IZ=33  :  C3SIZ=39  'NO.  OF  ITEMS  IN  EACH  COL 

1’E7 

1776 

C2SIZ=36  :  C4SIZ  26 

11F5 

177A 

GOSU8  5800  'GET  POSITION 

UFA 

177A 

IF  X.FIM*0  THEM  GOTO  191 

1209 

177C 

IF  RT. 5800=0  THEN  GOTO  190 

1218 

177E 

N.ERR*N.ERR  ♦  1 

1»20 

177E 

EO.HSG$<N.ERR)="PRIMART  OX  HAS  MULTIPLE  CCOES" 

1234 

177E 

GOTO  190 

1238 

177E 

1238 

177E 

190 

PR IMOXS=0 I AGN . TABSCX . FIN) 

124A 

177E 

124A 

177E 

191 

REM 

124B 

177E 

IF  PURPV>0  ANO  PRIMOXSO"  "  THEM  192 

1270 

177E 

If  PURPV=0  AMD  PRIMDXS»"  "  THEN  193 

1295 

177E 

IF  PURPV=0  THEN  194 

12A0 

177E 

PRIMOXS="S0O"+RIGHTS(STRS(PURPV+10O),2)  'USE  SOD  PLUS  LAST  TWO 

1’BB 

177E 

GOTO  194  'DIGITS  OF  PURPOSE  INDEX 

128F 

177E 

12BF 

177E 

192 

N.ERR=N.ERR  ♦  1 

12C7 

177E 

EO.MSGS(N.ERR)="PRIHARY  OX  INCLUDING  PURPOSE  HAS  MULTIPLE  COOES" 

1208 

177E 

GOTO  194 

RACP900 
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Offset 

Data 

Source  Line 

IBM  Personal  Coafxjter  BASIC  Conpitpr  VI. 00 

12E7 

177E 

ED.MSGS(N.ERR)=''PRIMARY  OX  OR  PURPOSE  OF  VISIT  NOT  COOED" 

12FB 

177E 

12FB 

177E 

194 

T.POS  »  T.POS  ♦  2  *  N.OIAG.COL 

130A 

177E 

NOX  •  133 

1311 

1780 

1311 

1780 

REN 

•••  SECOMOARY  OX 

1311 

1780 

I HP . ST0$=M 1 D$( TEXTS , T . POS , HDX ) 

1325 

1780 

DX2.BUF$="" 

132E 

1784 

H.STO=1 

1335 

1784 

1335 

1784 

196 

X.STO=IMSTR(M.STO, IMP.STOS,“1") 

1347 

1784 

IF  X.STO=0  THEM  GOTO  197  'THATS  ALL 

1356 

1784 

M.STO=X.STO  ♦  1  'NEXT  STARTING  POINT 

135E 

1784 

0X2.BUFS-0X2.BUFS  *  OIAGN.TABS(X.STO)  'AOO  CODE  TO  BUFFER  BY 

FIVES 

1373 

1784 

IF  N.STO  <«  LENdNP.STOS)  THEN  GOTO  196 

1386 

1784 

197 

IF  SECOXSs"  «  THEM  GOTO  198 

1398 

1784 

DX2.BUFS<0X2.BUFS+SEC0XS  'AOO  OTHER  SEC  OX  IF  THERE 

13A4 

1784 

13A4 

1784 

198 

T.POS  •  T.POS  ♦  NOX 

13AF 

1784 

13AF 

1784 

REM 

•••  DISPOSITIONS 

13AF 

1784 

REM 

READ  AS  ARRAY  *** 

13AF 

1784 

IHP.STOS=MIOS(TEXT$, T.POS, 13) 

13C2 

1784 

13C2 

1784 

GOSUB  5700  'CONVERT  ARRAY 

13C7 

1300 

1300 

1784 

1788 

1788 

REM 

DISPOS^BUF.STOS  'UP  TO  13  TWO  OIGIT  COOES 

1300 

1788 

1300 

1788 

IF  N.ERR  «  0  THEN  GOTO  997 

130F 

1788 

LPRINT  "LITHO  #  ";LITHOS;"  ...ERRORS" 

13f1 

1788 

FOR  1997  »  1  TO  N.ERR 

13FE 

178A 

LPRINT  USING  "###  ";1997; 

140A 

178C 

LPRINT  "==>  "lEO.MSGSCWT) 

1420 

178C 

NEXT  1997 

1431 

178C 

LN. COUNT  »  LN. COUNT  ♦  N.ERR  +  1 

1430 

178E 

CNTRLOPT  =  6 

1444 

178E 

GOSUB  9010  'REJECT  THE  FORM 

1449 

178E 

GOTO  998  'BYPASS  THE  OISK  WRITER - 

1440 

178E 

1440 

178E 

997 

REM  SINCLUOE:  'RACM900.MO2'  REM  INCLUDE  THE  BASE  FORM  DISK  WRITER 

144E 

178E 

REM 

144E 

178E 

REM 

AMBULATORY  CARE  INFORMATION  SYSTEM  3  APR  87 

•  **« 

144E 

178E 

REM 

D  R  BOLLING 

144E 

178E 

REN 

MOOULE  NAME  :  RACM900.MO2 

*««« 

144E 

178E 

REM 

*•••  SCANNER  PROGRAM  «  :  OCC  HEALTH  FORM 

•**« 

144E 

USE 

REM 

**•* 

•  ••« 

144E 

178E 

HEM 

••••  PURPOSE  :  CREATE  AND  WRITE  THE  DISK 

•**« 

144E 

178E 

REM 

*•••  RECORD  FOR  INPUT  TO  FOCUS 

144E 

178E 

REM 

144E 

178E 

REM 

144E 

USE 

REM 

RESERVED  LINE  NUMBERS  200-299 

144E 

USE 

REM 

144E 

USE 

RACP900 
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Offset 

144E 
U4E 
1A4E 
1453 
1453 
1453 
1453 
1453 
1453 
1458 
1472 
1477 
1482 
1482 
1482 
1482 
1482 
1482 
1482 
14B4 
14E6 
14E6 
1518 
154A 
154  A 
157C 
15AE 
i5AE 
15AE 
15AE 
15BF 
158F 
15C6 
1509 
’5EB 
15EB 
160B 
1610 
1618 
161B 
1625 
<6J8 
<638 
1638 
1738 
1649 
1649 
16'.0 
1663 
1675 
1675 
1693 
1690 
16A8 


PACE  15 
07-06-87 
15:02:00 

Data  Source  Line  IBM  Personal  Ccxnputer  BASIC  Conpiler  vl.OO 


178E 

178E 

178E 

178E 

178E 

178E 

178E 

178E 

178E 

178E 

179A 

179A 

179A 

179A 

179A 

179A 

179A 

179A 

179A 

179A 

179A 

179A 

179A 

179A 

179A 

179A 

179A 

179A 

179A 

179A 

179A 

179A 

179C 

17A0 

17A0 

17A0 

17A0 

17A0 

17AO 

17A0 

17A0 

17A0 

17A0 

17A0 

17A0 

17A0 

17A0 

17A0 

17A0 

17A0 

17A0 

17A0 

17A0 

17A0 


REN  BUILO  THE  OUTPUT  RECORD 

GOSUa  270  'BUILO  THE  RECORD  KEY 


REM 

REM  ***•  RECORD  TYPE  “I*  -  MAIM  TRANSACTIOM 
REM 


»****•»«***•• 


G0SU8  272  'BUILD  DATA  FOR  TYPE  1 

RECOUTS  =PGMIDS+''1‘'6RECKEYS+RECQ01$  'TRANSACTION  ID  PLUS  RECORD 
GOSUB  280 
PRINT  «1, RECOUTS 


REM  RECORD  TYPE  “2''  -  RECKEY  PLUS  PROCEDURE  CODE 

8E)i|  A****************************************************************** 


REM  ADD  ADDITIONAL  PROCEDURES  IF  ANY 

IF  AODPISo"  «  AND  PR2PRC1$<''N''  THEN  ESP.BUFISsESP.BUFIIaADDPIS 

IF  AODP2$<>'<  «  AND  PR2PRC2S<''N'>  THEN  ESP.BUF1SaESP.BUF1S«A0DP2$ 


IF  AODPISo"  ■  AND  PR2PRC1S»"Y“  THEN  ESP.BUF2$«ESP.BUF2$+AD0P1$ 

IF  A00P2$<>"  ■  AND  PR2PRC2$*"Y"  THEN  ESP.BUF2S»ESP.BUF2$+AD0P2S 


IF  AODPISo"  »  and  PR2PRC1$«"3“  THEN  ESP.BUF3SsESP.BUF3$+A00P1$ 

IF  AD0P2$o"  "  AND  PR2PRC2S=«3"  THEN  ESP.BUF3$»ESP.BUF3S+AODP2S 


REM  •••  PROCESS  PROV  1  PROCEDURES  •** 


IF  LEN(ESP.8UF1$)sO  THEN  GOTO  206 


RPOINTd 

202  REC0O2S=MI0$(ESP.BUF1$,RPOINT,5) 
IF  REC002S-"  "  THEN  GOTO  204 


REC0OTS=PGMI0$+"2"+REC«Y$+"1"+RECOO2t  'TRANSACTION  ID  PLUS  RECORD 
COSUB  280 
PRINT  mi, RECOUTS 

204  RPOINT  =  RPOINT  ♦  5 

IF  RPOINT  <  LEN<ESP.BUF1S)  THEN  GOTO  202 

REM  •••  PROCESS  PROV  2  PROCEDURES  ••• 

206  IF  LEN<ESP.BUF2S)=0  THEN  GOTO  211 

RPOINT=1 

208  REC002$=MID$(ESP.BUF2S, RPOINT, 5) 

IF  REC002$="  "  THEN  GOTO  210 

RECOUT$=PGMI0S*"2"+RECKErS+"2"»RECOO2S  'TRANSACTION  ID  PLUS  RECORD 
GOSUB  280 
PRINT  #1, RECOUTS 


i 
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16A8  17A0  210  RPOIHT  »  RPOINT  ♦  5 

1682  17A0  IF  RPOIHT  <  LEN(ESP.BUF2S)  THEN  GOTO  208 

16C5  17A0 

16C5  17A0  REM  ***  PROCESS  OUT  PROCEDURES  •** 

16C5  17A0 

16CS  17A0  211  IF  LEN(ESP.BUF3S)=0  THEN  GOTO  214 

1606  17A0 

1606  17A0  RPOINT=1 

1600  17A0  212  RECCD2$^10$(ESP.8UF3S, RPOINT, 5} 

16F0  17A0  IF  REC002S««  "  THEN  GOTO  213 

1702  17A0 

1702  17A0  REC0UT$»PGMID$+“2"+RECICEY$+"3“*REC002S  'TRANSACTION  ID  PLUS  RECORD 

1722  17A0  GOSU6  280 

1727  17A0  PRINT  lUI.RECOUTS 

1732  17A0 

1732  17A0  213  RPOINT  a  RPOINT  *  5 

173C  17A0  IF  RPOINT  <  LEN(ESP.BUF3S)  THEN  GOTO  212 

174F  17A0 

174F  17A0  214  REM  END  OF  TYPE  2  RECORDS 

1750  17A0 

1750  17A0  REM  •••*  RECORD  TYPE  “3"  -  RECICEY  PLUS  SPECIFIC  PRE  CLINIC  COOES 

1750  17A0  REM 

1750  17A0  IF  LEN<SPE.BUFS)aO  THEN  219 

1750  17A0 

1750  17A0  RPOINTal 

1764  17A0  215  X3$*MI0$(SPE.BUF$, RPOINT, 2) 

1777  17A4  IF  XStaolO"  THEN  REC003$="M“  :GOTO  216 

1792  17A8  IF  l{3la"11"  THEN  REC003$='’L"  :GOTO  216 

17A0  17A8  IF  X3$=''12"  THEM  REC003$="X"  ;GOTO  216 

17C8  17A8 

17C8  17A8  REC003S=RIGHT$(X3$,1) 

1707  17A8  IF  REC003$a"  "  THEN  218 

17E5  17A8 

17E5  17A8  216  RECOUTSaPGMIOS  ♦  "3"  ♦  RECXEYt  ♦  RECOOSS 

17FF  17A8  GOSUB  280 

1804  17A8  PRINT  #1,RECaUT$ 

180F  17A8 

180F  17A8  218  RPOINT=RPOINT*2 

1818  17A8  IF  RPOINT  <  LEN(SPE.BUF$)  THEN  215 

1827  17A8 

1827  17A8  219  REM  END  OF  TYPE  3  RECORDS 

1828  17A8 

1828  17A8  REM  ••••*•*•»••*••••••*****••***•*•**•**•********••»*•*»*••**••»**•*•*• 

1828  17A8  REM  RECORD  TYPE  "4"  -  RECKEY  PLUS  OTHER  COOES  ••••  ^ 

1828  17A8  REM 

1828  17A8 

1828  17A8  IF  LEN(OTH.BUF$)aO  THEM  GOTO  224 

1839  17A8 

1839  17A8  RPOINTal 

1840  17A8  220  REC0O4$aMID$(OTH.BUFt, RPOINT, 5) 

1853  17AC  IF  REC004$="  ■■  THEM  GOTO  222 

1865  17AC 

1865  17AC  RECOUT$aPGMI0$+"4"+RECKEY$+REC0O41  'TRANSACTION  10  PLUS  RECORD 


MCP900 

QCC  HEALTH  FORM  OESTRIN6/DECCDE  PROCRAN 


Offset 

Data 

Sourc 

187F 

17AC 

1884 

17AC 

188F 

17AC 

188F 

17AC 

222 

1899 

17AC 

18AC 

17AC 

18AC 

17AC 

18AC 

17AC 

224 

18AD 

17AC 

18AD 

17AC 

REM 

18A0 

17AC 

REM 

18A0 

17AC 

REM 

18A0 

17AC 

18AD 

17AC 

REM 

18A0 

17AC 

REH 

18AD 

17AC 

REH 

18A0 

17AC 

18A0 

17AC 

REH 

18A0 

17AC 

REM 

18A0 

17AC 

REH 

16A0 

17AC 

'l8A0 

17AC 

18BE 

17AG 

188E 

17AC 

18C5 

17AC 

264 

1808 

1780 

18EA 

mo 

18EA 

1780 

'904 

1780 

1909 

1780 

1914 

1780 

1914 

1780 

266 

191E 

1780 

1931 

1780 

1931 

17B0 

268 

1932 

1780 

1932 

1780 

REM 

1932 

17B0 

REM 

1132 

1780 

REM 

1932 

1780 

ly3F 

1780 

193F 

17B0 

1946 

1780 

274 

1959 

1784 

1967 

1784 

19o7 

1784 

1981 

1784 

1986 

1784 

1-)91 

1784 

1991 

1784 

276 

199A 

1784 

19,.  6 

1784 

I9/:6 

1784 

278 

l'’A7 

1784 
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G0SU8  280 
PRIHT  fI.RECGUTS 


IF  RPOIHT  <  LEN(OTH.BUFS)  THEN  GOTO  220 


REM  ENO  OF  TVPE  A  RECORDS 


RECORD  TYPE  "S"  -  RECKEY  PLUS  CROUP  I  DATA 

RECORD  TYPE  "O'*  -  RECKEY  PLUS  SPECIAL  PROGRAMS 


RECORD  TYPE  "7"  -  RECKEY  PLUS  SECOND  DX  CODE 


IF  LEN(DX2.BUF$)s0  THEN  GOTO  268 
RPOIHTal 

RECC07S=HIDS(DX2.BUF$,RP0INT,5) 

IF  REC007S="  «  THEN  GOTO  266 

RECOUTS  =PGMI0S+“7"+RECKEY$*REC0O7$  'TRANSACTION  ID  7 
GOSUB  280 
PRINT  #1, RECOUTS 

RPOIHT  »  RPOINT  ♦  5 

IF  RPOINT  •<  LEN<DX2,BUF$)  THEN  GOTO  26A 
REM  END  OF  TYPE  7  RECORDS 


*•««**•*****•*««***«««*««*««*«#*••«******•******#**•****#**** 

RECORD  TYPE  "9"  -  RECKEY  PLUS  DISPOSITIONS 


IF  LEN(DISPO$)=0  THEN  278 
RP0INT*1 

RECOD9S^IDS(DISPOS,RPOINT,2} 

IF  REC009S="  «  THEN  276 

RECOUTt=PGHID$  ♦  «9"  ♦  RECKEYS  ♦  REC009S 

GOSUB  280 

PRINT  #1, RECOUTS 

RP0INT=RP0INT»2 

IF  RPOINT  <  LEN(DISPOS)  THEN  274 
REH  END  OF  TYPE  9  RECORDS 


IUCP900 
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19A7  17B4  GOTO  299 

19AB  17BA 

19AB  17B4  REH  ••••**««**•***«•♦*****«««  »»»»»»»##«««»» 

19AB  17B4  REM  *•«  SUBROUTIME  270  -  BUILD  THE  RECORD  KEY  —•* 

19AB  17B4  REM  ***•••*•**«*••*********«*«•*««**«*«•*«**•*««*•**«•***«««•*******««« 

19AB  17BA  270  RECKEYS»"“ 

1964  17B4 

1964  17B4  REM  CLIHIC  ID  (PREFIX  ♦  COO) 

19B4  17B4  RECKEYS*  CLI.COOS 

19BD  17B4 

19B0  17B4  REM  •••  VISIT  DATE  **• 

19B0  17B4  RECKETS«RECKEYS«  VIDATES 

19C9  17B4 

19C9  17B4  REM  PRIMARY  PROVIDER  ••• 

19C9  17B4  RECXEYS  *  RECKEYS  ♦  PPROV.PFXS  ♦  PPROV.HUMS 

190C  17B4 

190C  17B4  REM  PATIEHT  SSN 

19DC  17B4  RECKEYS  «  RECKEYS  +  SSNS 

19E8  'TBA 

19E8  17B4  REM  ***  FAMILY  MEMBER  PREF 

19E8  17B4  RECKEYS  »  RECKEYS  ♦  FMEMPS 

19F4  17B4 

19F4  17B4  REM  LITHO  CODE  ••• 

19F4  17B4  RECKEYS  »  RECKEYS  ♦  LITHOS 

1AOO  17B4 

1AOO  17B4  REM  •**  FORM  NUMBER  ••• 

1A00  17B4  RECKEYS  «  RECKEYS  ♦  FRMNS 

1A0C  17B4 

1A0C  17B4  RETURN 

1A0F  17B4 

lAOF  1784  REM 

1A0F  17B4  REM  •••*  SUBROUTINE  272  -  BUILD  THE  DATA  FOR  TYPE  1 

1A0F  17B4  REM 

lAOF  17B4  272  RECa01S=«" 

1A18  1784 

1A18  1784  REM  •••  VISIT  COUNT 

1A18  1784  REC001S  °  RECQ01S  +  VCNTS 

1A24  1784 

1A24  1784  REM  PRIMARY  PROV  TIME 

1A24  1784  REC001S  =  REC001S  ♦  PPROV.TIMS 

1A30  1784 

1A30  1784  REM  SECONDARY  PROVIDER  •** 

1A30  1784  REC001S  «  REC001S  +  SPROV.PFXS  *  SPROV.NUHS 

1A43  1784 

1A43  1784  REN  **•  SECONDARY  PROVIDER  TIME  **• 

1A43  1784  RECC01S  »  REC001S  *  SPROV.TIMS 

1A4F  1784 

1A4F  1784  REM  •••  REASON  FOR  SECONDARY  PROVIDER  *** 

1A4F  1784  RECOOIS  =  RECOOIS  ♦  SPROV.REAS 

1A5B  1784 

1A5B  1784  REM  •••  APPORINTMENT  STATUS 

1A5B  1784  RECOOIS  =  RECOOIS  ♦  NOTSCS 

1A67  1784 

1A67  1784  REM 


REFERRAL  CODE  *** 


<UCP900 

OCC  HEALTH  FORM  DESTRING/DECOOE  PROGRAM 


I 


Offset 

Date 

Soul 

1A67 

17B4 

1A7A 

17B4 

1A7A 

17B4 

REM 

1A7A 

17B4 

i«86 

17B4 

iAa6 

17B4 

REM 

1A86 

1784 

1A92 

17B4 

1A92 

17B4 

REM 

1A92 

17B4 

1A9E 

17B4 

1A9E 

17B4 

REM 

1A9E 

17B4 

1AAA 

17B4 

1AAA 

17B4 

REM 

1AAA 

17B4 

1AB6 

17B4 

1AB6 

17B4 

REM 

1AB6 

17B4 

1AC2 

17B4 

1AC2 

17B4 

REM 

1AC2 

17B4 

1ACE 

17B4 

1ACE 

17B4 

REM 

1ACE 

17B4 

lADA 

17B4 

1A0A 

17B4 

REM 

1A0A 

17B4 

IAE6 

17B4 

1AE6 

17B4 

REM 

1AE6 

17B4 

1AF2 

17B4 

.AF2 

17B4 

REM 

nF2 

17B4 

1AFE 

17B4 

1AFE 

17B4 

REM 

1AFE 

17B4 

1S0A 

17B4 

'iJOA 

17B4 

1B0D 

1784 

1B0D 

17B4 

REM 

1BQ0 

17B4 

REN 

1BOO 

17B4 

REM 

1BOO 

17B4 

280 

;bib 

17B6 

1B2E 

17B6 

1831 

17B6 

IB31 

1786 

299 

1  '32 

1786 

1B32 

17B6 

REM 

1B32 

17B6 

'B32 

1786 

998 

1B!3 

17B6 

lii3T 

17B6 

999 
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REC001S  «  REC001B  «  REF.PFXS  «  REF.COOB 


RECOOIS  -  REC001S  ♦  NOTCLS 

***  JOB  RELATED  VISIT  **• 
RECQ01S  >  RECOOIS  *  J08RIFS 

•**  MIL  ONLY  DUTY  **• 
RECOOIS  >  RECOOIS  4^  NILOUTS 


RECOOIS  ■  RECOOIS  *  HILQTRS 


RECOOIS  ■  RECOOIS  «  NtLPROS 

**•  HOT  AVAILABLE  ••• 
RECOOIS  >  RECOOIS  *  NAVAILS 

ADMITTED  **• 

RECOOIS  ■  RECOOIS  *  ADMITS 

•••  ILLHESS  *** 

RECOOIS  <  REC001S  «  ILLNS 

I H JURY 

RECOOIS  a  RECOOIS  *  INJUS 

PURPOSE  OF  VISIT)  *** 
RECOOIS  «  RECOOIS  *  PURPS 

•••  PRIM  FOLLOU-UP/RUIE  OUT 
RECOOIS  3  RECOOIS  *  FU.ROS 


RECOOIS  «  RECOOIS  +  PRIMOXS 


SUBROUTIHE  280  -  PAD  THE  RECORD  TO  HAXLEMGTH 

**♦**********♦**♦**********♦***♦**••♦•***♦**** 


RECOUTS  >  RECOUTS  *  STRINGS(PAD,PAOS)  'PAD  THE  RECORD  WITH  FILL  CHAR 
RETURH 


-END  OF  MODULE  RACM900.MO2- 


998  REM  COHTIHUE 


999  REAOTYPE  =  7 


RACP900 

OCC  HEALTH  FORM  OESTRING/DECODE  PROGRAM 


Offset 

Data 

1B3A 

17B6 

1B4A 

17B8 

1B4E 

17B8 

1B4E 

17B8 

1B4E 

17B8 

1B4E 

17B8 

1B4F 

17B8 

1B4F 

17B8 

1B4F 

17B8 

1B4F 

17B8 

1B4F 

17B8 

1B4F 

17B8 

1B4F 

17B8 

1B4F 

17B8 

1B4F 

17B8 

1B4F 

17B8 

1B4F 

17B8 

1B4F 

17B8 

1B4F 

17B8 

1B61 

17B8 

1B8F 

17B8 

1B90 

17C4 

1B9E 

17C4 

1BAC 

17C4 

1BB3 

17C4 

1BC9 

17C4 

1B0F 

17C4 

1BE3 

17C4 

1BE6 

17C4 

1BE6 

17C4 

1BEA 

17C4 

1BF1 

17C4 

1BF1 

17C4 

iBfl 

17C4 

1BF2 

17C4 

1BF2 

17C4 

1BF2 

17C4 

1Bf2 

17C4 

1BF2 

17C4 

1BF2 

17C4 

1BF2 

17C4 

1BF2 

17C4 

1BF2 

17C4 

1BF2 

17C4 

1BF2 

17C4 

1BF2 

17C4 

1BF2 

17C4 

1BF2 

17C4 

1BF2 

17C4 

18F2 

17C4 

1BF3 

17C4 

1C07 

17C8 

1C11 

17CA 

1C2C 

17CA 

Source  Line 

IF  LNLCOUNT  >  48  THEM  COSUB  7100  'PRINTER  HEADING 
GOTO  10 
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REM  END  OF  SCAM/DECODE/WRITE  LOOP  «.»«»»===»=====»»»«««»*«»«»>**=« 


1000  REM  SINCLUDE:  'RACSIOOO.SUB*  INCLUDE  THE  VERIFY  LOGON  SUB 

********************************************************************* 

REM  *  NAME:  RACS1000  LOGON  VERIFICATION  SUBROUTINE  * 

REM  •  Date:  28  Feb  84  PATIENT  REGISTRATION  PROGRAM  * 

ggif  ********************************************************************* 


PATIENT  OMR  INPUT  PROGRAM  * 

* 

This  program  verifies  user  is  logged  on  properly.  If  there  Is  no  * 
valid  user  logged  on  at  the  tiaie  of  execution,  this  subroutine  will* 
chain  to  the  logon  program  RACPOS,  otherwise  a  return  is  issued.  * 

RESERVED  LINE  NUMBERS  ARE  1001  THRU  1010 


REM 
REM 
REM 
REM 
REM 
REM 
REM 
REM 

1001  OPEN  •■I",1,“RACLOG.OAT'' 

IF  EOf(l)  THEN  1002 

INPUT  #1,USER$(1},0TS,TNS,PI0$ 

IF  USERSd)  «  •«  THEN  1002 
IF  USERSd)  »  »**••*•«  then  1002 
CLOSE  1 

SCREEN  0,1, 0,0 
COLOR  FORE, BACK, BORO 
CLS 
RETURN 


■HAKE  THEM  LOG  ON  FIRST 

•HAKE  THEM  LOG  ON  FIRST 

•HAKE  THEM  LOG  ON  FIRST 


1002  CLOSE 

CHAIN  "RACPOS" 

•  s3ss3<»»sEN0  of  LOGON  VERIFY  SUBROUTINE  1000«»=*=»===**»»*»«*»»»'«»»»»» 


2000  REM  SINCLUOE:  •RACS2000.SUB'  INCLUDE  THE  RIPLY/OELAY  SUB 
REM 

REM  ••••  AMBULATORY  CARE  DATA  BASE  13  APR  85 


REM 

**«• 

SKIP  COLE 

REM 

SUBROUTINE  NAME 

RACS2000.SU8 

REM 

*•** 

SCANNER  PROGRAM  # 

ALL 

REM 

**«* 

FUNCTION 

THIS  SUBROUTINE  MODULE 

REM 

SERVERS  AS  A  WAIT  AND  REPLY 

REM 

#**• 

ENTRY  MODULE 

REM 

«**• 

INPUT 

; 

SINGLE  KEYBOARD  ENTRY 

REM 

**** 

REM 

OUTPUT 

; 

KEYBOARD  ENTRY  -  UPPER  CASE 

REM 

REM 

««** 

RESERVED  LINE 

REM 

*«** 

NUMBERS 

; 

2001-2010 

REM 

2001  REM  REPLY  FUNCTION 

2002  REPLT$«IMKEY$  :  IF  REPLYS=""  THEN  2002 
REPLY=ASC(REPLYS) 

IF  REPLY  >  90  THEM  REPLY$*CHRS(REPLY  XOR  32)  'CONVERT  TO  CAPS 
IF  REPLYS  <  "A"  OR  REPLYS  >  "Z"  THEN  REPLY$="?" 


***• 


*••• 

•••* 

*««• 

**•* 
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1CSB 

17CA 

1CSB 

17CA 

1CSB 

17CA 

5000 

1C5C 

17CA 

REM 

1C5C 

17CA 

REM 

1C5C 

17CA 

REM 

1C5C 

17CA 

REM 

tcsc 

17CA 

REN 

1C5C 

17CA 

REM 

1C5C 

17CA 

REN 

1C5C 

17CA 

REM 

1C5C 

17CA 

REM 

1C5C 

17CA 

REM 

1C5C 

17CA 

REM 

1C5C 

17CA 

REM 

1C5C 

17CA 

REM 

1C5C 

17CA 

REN 

1C5C 

17CA 

REN 

ICSC 

17CA 

REM 

1CSC 

17CA 

REM 

1C5C 

17CA 

REM 

ICSC 

17CA 

REM 

)C5C 

17CA 

REN 

ICSC 

17CA 

REM 

ICSC 

17CA 

REN 

1C5C 

17CA 

1C63 

17CA 

1C76 

17CC 

1C8C 

17CE 

1C9F 

1700 

1C9F 

17D0 

1CBS 

17D0 

1CCB 

17D0 

1CE1 

17D0 

1CF7 

17D0 

1CF7 

17D0 

REN 

1CF7 

17D0 

1CFE 

mo 

•DOO 

mo 

1D22 

mo 

1D29 

17D0 

1D29 

mo 

5005 

1DA8 

17D0 

IDA8 

17D0 

5009 

1DAB 

17D0 

1D4B 

17D0 

REM 

1DAB 

17D0 

10AB 

17D0 

1DAB 

17D0 

5500 

10AC 

17D0 

5600 

1040 

1700 

5700 

U  '.£ 

17D0 

REN 

1D4E 

17D0 

REN 

1D4' 

17D0 

REM 

REM  SINCLUDE:  'RACSSOOO.SUB'  IHCLUDE  THE  DATE  EDITOR  SUB 
****  AMBULATORY  CARE  DATA  BASE  13  APR  1 


SUBROUTINE  NAME 
SCANNER  PROGRAM  « 
FUNCTION 


RESERVED  LINE 
NUMBERS 


E  13  APR  as 

SKIP  COLE 

RXXSSOOO.SUB 

ALL 

THIS  SUBROUTINE  MODULE 
PERFORMS  A  DATE  EDIT 

DATE  TO  BE  CHECKED  MUST  BE 
IN  THE  VARIABLE  NAMED 
•CK.SOOOB* 

IN  THE  FORMAT  "YYMMOD" 

■RT.SOOO*  IS  THE  RETURN  CODE 
VARIABLE.  IF  THIS  VARIABLE 
CONTAINS  ANY  NUMBER  OTHER 
THAN  0.  AN  ERROR  WAS  FOUND 
IN  THE  DATE. 


5001-5009 


RT.SOOO  s  0 

CKTEAR  =  VAL(LEFT$(CK.5000$,2)) 
CKMONTH  X  VAL(MI0S(CK.S000$,3,2}) 
CKDAY  X  VAL(RIGHT$(CK.S000S,2)) 


■YEAR  NUMERIC  VALUE 
•MONTH  NUMERIC  VALUE 
•DAY  NUMERIC  VALUE 


IF  CKMONTH  <  1  THEN  RT. 5000x1  :  GOTO  5009 
IF  CKMONTH  >  12  THEN  RT. 5000x1  :  GOTO  5009 
IF  CKDAY  <  1  THEM  RT.5000»2  :  GOTO  5009 
IF  CKDAY  >  31  THEN  RT. 5000=2  :  GOTO  5009 


N0LENGTH(2)  =  28 

IF  CKMONTHo  2  THEN  GOTO  5005  •MUST  BE  FEBRUARY 

IF  (CKYEAR  MOO  A)  <>  0  THEN  GOTO  5005  •MUST  BE  A  LEAP  YEAR 
MOLENGTH(2)  =  29 

5005  IF  CKDAY  >  NOLENGTN(CKHONTH>  THEN  RT. 5000=3  :  GOTO  5009 


-END  OF  SUBROUTINE  5000 


AMBULATORY  CARE  DATA  BASE 


29  JUL  85 
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Offset 

Oats 

Source  Line 

IBM  Personal  Cotifxjter  BASIC  CoapUer  V4.OO 

me 

1700 

REH 

•M*  SUBROUTINE  NAME 

:  RXXS5700.SU8 

1D4E 

1700 

REM 

SCANNER  PROGRAM  « 

:  ALL 

*•** 

1D4E 

1700 

REM 

FUNCTIOM 

THIS  SUBROUTINE  MODULE 

**«* 

104E 

1700 

REH 

CONVERTS  A  BINARY  ARRAY  INTO 

***• 

1D4E 

1700 

REM 

*«*« 

TWO  CHAR  COOES. 

**•* 

1D4E 

1700 

REM 

•«** 

1D4E 

1700 

REH 

*•••  INPUT 

INP.STOS  AS  STRING 

*«•* 

1D4E 

1700 

REH 

*«•* 

**** 

1D4E 

1700 

REM 

**** 

1D4E 

1700 

REM 

•***  OUTPUT 

BUF.STOS  AS  STRING. 

*«**• 

104E 

1700 

REM 

***« 

**** 

1D4E 

1700 

REM 

**** 

1D4E 

1700 

REM 

••••  RESERVED  LINE 

•*«* 

104E 

1700 

REM 

**«  NUMBERS 

:  5710-5730 

104E 

1700 

REM 

104E 

1700 

104E 

1700 

BUF.STOS*"" 

1057 

1700 

N.STO-1 

1D5E 

1700 

5710 

X.STO>INSTR(N.STO,tNP.STOS, 

"I") 

1070 

1700 

IF  X.STO>0  THEN  GOTO  5720 

'THATS  ALL 

107F 

1700 

H.STO  »  X.STO  ♦  1 

•NEXT  STARTING  POINT 

1087 

1700 

X.STO  »  X.STO  ♦  100 

•PAD  WITH  LEADING  ZERO 

1091 

1700 

BUF.STOS  >  BUF.STOS  *  RIGHT$(STR$(X.STO).2} 

10A7 

1700 

IF  N.STO  <>  LEN(INP.STOS)  THEN  GOTO  5710 

10BA 

1700 

1DBA 

1700 

5720 

RETURN 

10B0 

1700 

1700 

10B0 

1700 

5800  REH  SIHCLUDE:  ■RACS5800.SUB' 

INCLUDE  FOUR  COL  OX  CONVERTER 

1DBE 

1700 

REH 

10BE 

1700 

REN 

***  AMBULATORY  CARE  DATA  BASE  30  JUL  85 

*** 

10BE 

1700 

REM 

•** 

0  R  BOLLING 

10BE 

1700 

REM 

•••  SUBROUTINE  NAME  : 

RXXS5800.SU8 

1DBE 

1700 

REM 

SCANNER  PROGRAM 

AS  APPROPRIATE 

108E 

1700 

REM 

•••  FUNCTION 

THIS  SUBROUTINE  MODULE  READS 

*** 

10BE 

1700 

REM 

*** 

FOUR  COLUMNS  IN  OX  AREA  AND 

*«• 

1DBE 

1700 

REM 

*«* 

CONVERTS  TO  A  POSITION  IN  A 

10BE 

1700 

REM 

•  ** 

TABLE.  AN  ERROR  CODE  IS 

10BE 

1700 

REM 

*«• 

RETURNED  IF  MULTIPLE  COOES  ARE 

**• 

1DBE 

1700 

REM 

*«* 

PRESENT. 

10BE 

1700 

REM 

•** 

10BE 

1700 

REM 

•••  INPUT 

X.POS  -  STARTING  POSITION  IN 

10BE 

1700 

REH 

*** 

STRING 

••• 

10BE 

1700 

REM 

••• 

108E 

1700 

REM 

•••  OUTPUT 

X.FIN  -  TABLE  POSITION  OF  OX 

•** 

10BE 

1700 

REM 

RT.5800  <  1  ON  ERROR 

10BE 

1700 

REM 

*** 

**• 

108E 

1700 

REH 

RESERVED  LINE  NUMBERS 

:  5801  -  5899 

10BE 

1700 

REM 

10BE 

1700 

RT.5800=:0  'INITIALIZE 

ERROR  INDICATOR 

10C5 

1700 

X.FIN^O  'INITIALIZE 

TABLE  OFFSET  RESULT 

10CC 

1700 

10CC 

1700 

REM  ••  COLUMN  1  *• 

10CC 

1700 

X=0  'STARTING 

POINTER 

RACP900 

OCC  HEALTH  FORM  DESTRINC/OECOOE  PROGRAM 
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! 

i 


te 


1DD3 

1700 

1DDA 

1702 

1DF1 

1702 

1E00 

1702 

1E07 

1702 

1E07 

1702 

'E08 

1702 

1E17 

1702 

1E22 

1702 

1E2B 

1702 

1E32 

17D2 

1E49 

1702 

1E58 

17D2 

1E67 

1702 

1E72 

1702 

1E72 

1702 

1E73 

1702 

1E82 

1702 

1E80 

1702 

1E96 

1702 

1E9D 

1702 

1EB4 

17D2 

1EC3 

1702 

1E02 

1702 

1EOO 

1702 

lEOD 

17D2 

’EOE 

17D2 

1EE0 

17D2 

1EF8 

1702 

1F01 

1702 

1'08 

1702 

1F1F 

1702 

1F2E 

1702 

1F30 

1702 

IF48 

17D2 

1F48 

1702 

1  -49 

17D2 

1F40 

1702 

1F4D 

1702 

1F54 

17D2 

1F54 

1702 

1F57 

1702 

■F57 

1702 

1F'.,7 

1702 

IFS’ 

1702 

’F57 

1702 

1-56 

17D2 

1F58 

1702 

1FS8 

1702 

1F53 

1702 

1F58 

1702 

1'58 

17D2 

1F58 

17D2 

1F58 

17D2 

X.SIZ>C1SIZ 

X.STO>VAL(MIDS{TEXTS,X.POS,2)) 

IF  X.ST0«0  THEN  GOTO  5802 
X.FINaX.STO 

5802  REM  *•  COLUMN  2  ** 

IF  C2SIZ=0  THEN  GOTO  5804 
X>X+X.SIZ 
X.P0S*X.P0S+2 
X.SIZ>C2SIZ 

X.ST03VAL(MIOS(TEXTS,X.POS.2)) 

IF  X.STO>0  THEN  GOTO  5804 

IF  X.FINoO  THEN  GOTO  5890  'ERROR  -  MULTIPLE  CODE 
X.FINeX.STO  *  X 


5804  REM  *•  COLUMN  3  •• 

IF  C3StZ«0  THEN  GOTO  5806 
X>>X'»X.SIZ 
X.POS=X.POS>2 
X.SIZ>C3SIZ 

X .  STO»VAL  (MI  0S<  TEXTS ,  X .  POS ,  2)  ) 

IF  X.ST0«0  THEN  GOTO  5806 

IF  X.FIMOO  THEN  GOTO  5890  'ERROR  •  MULTIPLE  CODE 
X.FIN«X.STO  ♦  X 

5806  REM  **  COLUMN  4  •* 

IF  C4SI2=0  THEN  GOTO  5808 
X=X*X.SIZ 
X.POS=X.POS+2 
X.SIZ=C4SIZ 

X.STO=VAL(MIDS<TEXTS,X.POS,2)) 

IF  X.STO*0  THEN  GOTO  5808 

IF  X.FINoO  THEN  GOTO  5890  'ERROR  -  MULTIPLE  CODE 
X.FIN=X.ST0  ♦  X 


5808  REM 

GOTO  5899 

5890  RT. 5800=1  'ERROR  -  MULTIPLE  COOES 
5899  RETURN 

REM  . ENO  OF  SUBROUTINE  RXXS5800.SUB 


6000  REM  SINCLUOE:  'RACS6000.SUB'  INCLUDE  THE  INSTRING  DECODE  SUB 


REM 

REM 

REM 

REM 

REM 

REM 

REM 


***« 

**** 

**** 

**** 

***• 

**•* 


AMBULATORY  CARE  DATA  BASE 


SUBROUTINE  NAME 
SCANNER  PROGRAM  » 
FUNCTION 


13  APR  85 
SKIP  COLE 

RXXS6000.SUB 

ALL 

THIS  SUBROUTINE  MODULE 
PERFORMS  INSTRING  SEARCH 


**** 

**** 

**** 

**** 

***« 

*«*= 


•*** 


***« 


RACP900 

OCC  HEALTH  FORH  DESTRINC/OECOOE  PROGRAM 


PAGE  24 
0’-06-87 
15:02:00 


Offstt 

Data 

Source  Line 

IBM  Personal  Coaputer  BASIC  Ccxnpiler  vl.OO 

1F58 

17D2 

REM 

INPUT 

:  STRING  TO  BE  SEARCHED  MUST 

*«*« 

1F58 

17D2 

REM 

BE  IN  THE  VARIABLE  NAMED  : 

1«8 

17D2 

REM 

***« 

'XS* 

**•* 

1F58 

1702 

REM 

*«*• 

1F58 

1702 

REM 

***• 

OUTPUT 

■TOT'  <  TOTAL  NUMBER  OF 

*««« 

1F58 

1702 

REM 

HITS  IN  THE  DESTRING 

**•« 

1F58 

1702 

REM 

*•*« 

•HOLOSO*  IS  THE  ARRAY 

1F58 

1702 

REM 

•««« 

CONTAINING  THE  NUMERIC 

1FS8 

1702 

REM 

VALUE  OF  THE  HIT  POSITIONS 

1F58 

1702 

REN 

***« 

1F58 

1702 

REM 

•*«**«**«***«*•««*«*«****«*****««««*•«••««««««•««*****••««***••*•** 

1FS8 

1702 

REM 

RESERVED  LINE 

1F58 

1702 

REM 

NUMBERS 

:  6001-6009 

*«*« 

1F58 

1702 

REN 

*««••«***«****••••«•*««•*#• 

••«****•**«*•**•«*••**•*«*#•«••******«*• 

1F58 

1702 

6001 

PTR  »  INSTRIXS,*!") 

1F86 

1704 

TOT  »  0 

1F60 

1706 

WHILE  PTR  >  0 

1F78 

1706 

T0T»T0T*1 

1F80 

1706 

HOLOStrOT)  •  RIGHTS(STRS<PTR),2) 

1FA2 

1706 

PTRspTR+1 

1FAA 

1706 

PTR  «  INSTR(PTR,XS, 

"I") 

1F8C 

1706 

UEND 

1FC0 

1FC3 

1FC3 

1706 

1706 

1706 

RETURM 

INk  KAAdOvUU • 

1FC3 

1706 

1FC3 

1706 

1FC3 

1706 

7000  REM  S INCLUDE:  'RACSTOOO.SUB* 

INCLUDE  THE  SCREEN  HEADER  SUB 

1FC4 

1706 

REM 

*••*«««««*««««*«*•««•*♦««*♦***«*««**•♦«***••*««**•••****••*«*'»•«*•• 

1FC4 

1706 

REN 

AMBULATORY  CARE  DATA  BASE  13  APR  85 

•**« 

1FC4 

1706 

REM 

SXIP  COLE 

*••• 

1FC4 

1706 

REM 

**«• 

SUBROUTINE  NAME 

:  RACSTOOO.SUB 

1FC4 

1706 

REM 

•««* 

SCANNER  PROGRAM  « 

ALL 

•••• 

1FC4 

1706 

REM 

**•* 

FUNCTION 

:  THIS  SUBROUTINE  MODULE 

•••• 

1FC4 

1706 

REN 

**«« 

PRINTS  THE  STANDARD  SCREEN 

1FC4 

1706 

REM 

HEADING. 

1FC4 

1706 

REM 

INPUT 

COMMON  VARIABLE  USERS(2) 

1FC4 

1706 

REM 

SYSTEM  DATE 

1FC4 

1706 

REM 

***« 

•*** 

1FC4 

1706 

REM 

*•** 

OUTPUT 

SCREEN  HEADING 

1FC4 

1706 

REM 

•••• 

1FC4 

1706 

REM 

RESERVED  LINE 

1FC4 

1706 

REM 

***• 

NUMBERS 

:  7001-7010 

1FC4 

1706 

REM 

1FC4 

1706 

■ 

1FC4 

1706 

7001 

LOCATE 

1,1 

1FCE 

1706 

PRINT 

'U.S.  ARMY  AMBULATORY 

CARE  INFORMATICS  SYSTEM" 

1FD6 

1706 

LOCATE 

1,65 

1FE3 

1706 

PRINT 

DATES; 

1FEB 

1706 

LOCATE 

2,1 

1FF8 

1706 

PRINT 

•niSER  :  ";USER$<1) 

2005 

1706 

RETURN 

2008 

1706 

2008 

1706 

7100  REM  SIMCLUOE:  '84057100.508' 

INCLUDE  THE  PRINTER  HEADER  SUB 

RACP900 
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2009 

17D6 

2009 

17D6 

2009 

17D6 

2009 

17D6 

2009 

17D6 

2009 

17D6 

2009 

17D6 

2009 

17D6 

2009 

17D6 

2009 

17D6 

2009 

17D6 

2009 

17D6 

?009 

17D6 

2009 

17D6 

2009 

17D6 

2009 

17D6 

2009 

17D6 

201 F 

17D6 

202C 

17DA 

203F 

17DA 

2047 

17DA 

2064 

17DA 

2070 

17DA 

2078 

17DA 

207F 

17DA 

2082 

17DA 

2082 

17DA 

2083 

17DA 

2083 

17DA 

2083 

17DA 

c083 

17DA 

2083 

17DA 

2083 

17CA 

2083 

17DA 

2083 

17DA 

2083 

17DA 

2083 

17DA 

2083 

17DA 

2083 

17DA 

2083 

17DA 

<.083 

17DA 

2083 

17DA 

2C33 

17DA 

2083 

17DA 

2083 

17DA 

2063 

170A 

2083 

17DA 

2083 

17DA 

2083 

17DA 

208: 

17DA 

2083 

17DA 

2083 

17DA 

20  IS 

17DA 

iC3A 

17CC 

REN 

REM 

**«* 

AMBULATORY  CARE  DATA  BASE  13  APR  85 

«««** 

•*«* 

REM 

SKIP  COLE 

REM 

SUBROUTINE  NAME 

RXXS7100.SUB 

REM 

SCANNER  PROGRAM  « 

ALL 

*•** 

REM 

FUNCTION 

THIS  SUBROUTINE  NODULE 

REM 

PRINTS  THE  STANDARD  HEADING 

**** 

REM 

ON  THE  PRINTER. 

*♦** 

REM 

INPUT 

DATE .PAGE .PGMIDS, PONT  I TLS 

REN 

•*** 

REM 

«*•« 

OUTPUT  :  PRINTER  HEADING,  LN. COUNT 

REM 

***• 

REN 

RESERVED  LINE 

**•« 

REM 

REN 

7101 

NUMBERS  :  7101-7110 

>  0  THEN  LPRINT  CHRS(12); 

IF  PAGE 

LPRINT 

■ARNY  AMBULATORY  CARE  INFORMATION  SYSTEM _  ■;PGMTITLS; 

LPRINT  TAB(70);DATES 
PAGE=PAG£«1 

LPRINT 

"PROGRAM  ";PGMI0S;TAB(70);«PAGE“; 

LPRINT  USING  ••(»###";PACe 

LPRINT 

LN.COUNT=3 

RETURN 

8000 

REM  SINCLUDE:  ' RACS80QO . SUB ■  INCLUDE  THE  DECODE  SUB  GROUP 

REM 

REM 

AMBULATORY  CARE  DATA 

BASE  13  APR  85 

REM 

•««« 

SKIP  COLE 

REN 

SUBROUTINE  NAME 

RXXS8000.SUB 

**« 

REM 

SCANNER  PROGRAM  « 

ALL 

**« 

REM 

FUNCTION 

THIS  SUBROUTINE  MODULE 

REM 

*«*•* 

IS  A  GROUPING  THAT  PERFORMS 

REM 

VARIOUS  DECODING  FUNCTIONS 

REM 

**•* 

ON  THE  SCANNER  DATA 

REM 

REM 

8001  -  DECODE  THE 

HEADER  POSITIONS  (POINTER  0-20) 

REM 

**•« 

8050  -  CHECK  FOR  END  OF  JOB 

REM 

8100  -  PRINT  THE  HEADER  DATA  ON  THE  SCREEN 

REM 

•  »** 

8200  -  OECnE  THE 

RESPONSE  POSITIONS  (POINTER  21-.. 

)  ••• 

REM 

**** 

(RETURNED  IN  TEXTS  STRING  VARIABLE) 

REM 

•  «*« 

•  •• 

REM 

INPUT 

SHEET  RECORD.  RECORD  LENGTH 

*•* 

REM 

**•* 

REM 

OUTPUT 

•TEXTS'  TRING  VARIABLE 

*•* 

REN 

REN 

**** 

RESERVED  LINE 

**• 

REM 

«*•* 

NUMBERS 

8001 -8500 

**• 

REH 

*«**« 

•DECODE  THE  HEADER  ONLY 
8001  POINTER  =  0 

RECOROPTR  =  VARPTR(SHEETREC(0)) 

! 
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Offset 

Oats 

Source  Line 

2091 

17DE 

FOR  J8000  s  1  TO  21 

2098 

17DE 

8002 

TEXTS-  TEXTS+CHRS(PEEK(RECOROPTR  ♦  POINTER)) 

20B6 

17DE 

POINTER^POINTER-^I 

20BE 

17DE 

NEXT  J8000 

20CO 

17E0 

PROGRAMS*  LEFTS(TEXTS,3) 

200C 

17E4 

BATCHS*  NI0S(TEXTS,4,3) 

20EE 

17E8 

SERIALS*  NIDS(TEXTS,7,4) 

2100 

17EC 

RUNIOS*  HIDS(TEXTS,11,1) 

2112 

UFO 

FORMS*  NI0S(TEXTS,12,2) 

2124 

17F4 

POCKETS*  MI0S(TEXTS,14,1) 

2138 

17F8 

SCANERR1S*MIDS(TEXTS, 16,2) 

2148 

17FC 

SCANERR2S*MI0S(TEXTS, 18,2) 

21SA 

1800 

SCANERR3S*M I DS( TEXTS ,20,2) 

216C 

1804 

GOTO  8500 

2170 

1804 

2170 

1804 

8050 

REM  CHECK  FOR  END  OF  JOB/ENO  OF  BATCH 

2171 

1804 

IF  PROGRAMS  *  PGMIDS  THEN  GOTO  8500 

2183 

1804 

LPRINT  STRIMGS<80,"*") 

2191 

1804 

LPRINT 

2199 

1804 

LPRINT  "RECOROS  PROCESSED  ...  «;SERtALS 

21A8 

1804 

LPRINT  "STARTED  AT  .  «;BTIM£S 

21 B3 

1804 

LPRINT  “ENDED  AT  .  “;TIMES 

21C0 

1804 

LPRINT  CHRS(12) 

21C8 

1804 

GOTO  30000 

21CF 

1804 

21CF 

1804 

8070 

REM  CHECK  FOR  SCANNER  ERRORS 

2100 

1804 

IF  POCKETS  *  "  “  GOTO  8500 

21E2 

1804 

LPRINT  LITHOS; 

21EA 

1804 

LPRINT  “  ...  SCANNER  ERRORS  : 

21 F2 

1804 

LPRINT  SCANERRIS;"  / 

21FF 

1804 

LPRINT  SCANERR2S;"  / 

220C 

1804 

LPRINT  SCANERR3S 

2214 

1804 

LN*LN+1 

221C 

1806 

GOTO  999 

2220 

1806 

2220 

1806 

8100 

REM  PRINT  THE  HEADER  VARIABLES  ON  THE  TUBE.... 

2221 

1806 

LOCATE  5,1:PRIHT  "PROGRAM  ".-PROGRAMS; 

223B 

1806 

223B 

1806 

PRINT  "  BATCH  ";BATCHS; 

2248 

1806 

PRINT  "  RUN  ": RUN  IDS; 

225S 

1806 

PRINT  "  FORM  FORMS; 

2262 

1806 

PRINT  "  POCKET  ".-POCKETS 

226F 

1806 

GOTO  8500 

2273 

1806 

2273 

1806 

8200 

REN  DECODE  THE  RESPONSE  POSITIONS 

2274 

1806 

POINTER  *  21 

227B 

1806 

RECORDPTR  *  VARPTRISHEETRECCO)) 

2282 

1806 

FOR  J8000  *  22  TO  RECOROLENGTH 

228F 

1808 

8202 

TEXTS  *  TEXTS*CHRS(PEEK(RECOROPTR  ♦  POINTER)) 

22AO 

1808 

POINTER=POINTER+1 

2285 

1808 

NEXT  J8000 

22C6 

1808 

22C6 

1808 

8500 

RETURN 

22C9 

1808 
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Offset 

22C9 
’2C9 
22C9 
22CA 
22CA 
22CA 
22CA 
22CA 
22CA 
22CA 
22CA 
22CA 
22CA 
22CA 
22CA 
22CA 
22CA 
22CA 
22CA 
22CA 
22CA 
22CA 
22CA 
22CA 
22CA 
22CA 
22C8 
2JD2 
22D9 
22EQ 
22E7 
22EE 
22F5 
22FC 
ZVC 
2308 
230F 
2320 
2329 
2345 
2349 
2349 
2349 
2349 
23  9 
2349 
2349 
2349 
2349 
2349 
2T49 
234; 
2349 
2349 
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Data 

Source  Line 

IBM 

1808 

1808 

1808 

9000  REN  SINCLUDE:  •RACS9000.SUB' 

INCLUDE  THE  SCANNER  CONTROL  SUB 

1808 

REN 

*^*'***********«***«********«*«**«****»***«**********«tt****««**««** 

1808 

REN 

•***  AMBULATORY  CARE  DATA  BASE  13  APR  85 

**** 

1808 

REM 

SKIP  COLE 

1808 

REN 

PROGRAM  NAME 

RACS9000.SUS 

1808 

REM 

••••  SCANNER  PROGRAM  0 

ALL 

*«** 

1808 

REN 

*•••  FUNCTION 

:  THIS  SUBROUTINE  MODULE 

*•«* 

1808 

REM 

CONTROLS  THE  SCANNER  I/O 

1808 

REM 

*•** 

1808 

REM 

••••  INPUT/OUTPOT 

:  REFER  TO  THE  ASYNCHRONOUS 

**** 

1808 

REM 

COMMUNICATIONS  MANUAL  AND  THE 

**•* 

1808 

REM 

**«• 

PRE-RELEASED  SOFTWARE  GUIDE 

1808 

REM 

*•*« 

•  *** 

1808 

REM 

1808 

REM 

****  RESERVED  LINE 

1808 

REM 

NUMBERS 

:  9001-9100 

**«* 

1808 

REN 

1808 

1808 

1808 

REN 

*«*«*«**««•*««««***«««*««*««««««**•*•****«**«*************«•••***•• 

1808 

REN 

SUBROUTINE  9001  -  PROTOCOL  SETUP  FOR  SCANNER 

1808 

REM 

ARGUMENTS:  PRESET  ... 

SEE  BELOW 

***** 

1808 

9001 

REM 

1808 

PROTOCOL(O)  =  9600 

■BAUD  RATE 

1808 

PROTOCOL! 1)  =  78 

•PARITY  (SEE  PAGE  4-8  OF  MANUAL) 

1808 

PROTOCOL<2)  »  8 

■DATA  BITS 

1808 

PROTOCOL(3)  =  1 

'STOP  BITS 

1808 

PROTOCOL(4)  *  2 

•RS-232  PORT 

1808 

PR0T0C0L<5)  »  0 

•WRITE  TIME-OUT 

1808 

PROTOCOL (6)  »  0 

•READ  TIME-OUT 

1808 

me 

ERRSTATS  <  SPACES<60) 

1808 

ARGPTR  =  VARPTR(PROTOCOL(0)) 

180A 

CALL  SETUP  (ARGPTR, ERRSTATS) 

180A 

ERRMSG$="" 

180A 

IF  ASCCERRSTATS)  <>  64  THEN  ERRMSC$*"SETUP  ERROR  '■♦ERRSTATS 

180A 

GOTO  9100 

180A 

180  A 

REM 

180A 

REM 

•••*  SUBROUTINE  9010  -  CONTROL  OPTIONS  FOR  SCANNER 

180A 

REM 

••••  ARGUMENTS:  CNTRLOPT 

180A 

REM 

CNTRLOPT  =  1  =  START 

SCANNER  (SI) 

180A 

REM 

*•••  CNTRLOPT  =  2  =  STOP 

SCANNER  (SO) 

180A 

REM 

•»•*  CNTRLOPT  »  3  «  TERMINATE  COMMUNICATIONS  TO  SCANNER  (DC3) 

180A 

REM 

•••*  CNTRLOPT  »  4  =  CLEAR 

TRANSPORT  PATH  (DC2) 

180A 

REM 

CNTRLOPT  =  5  »  SELECT 

PRIMARY  STACKER  "31" 

180A 

REN 

***•  CNTRLOPT  =  6  =  SELECT 

SECONDARY  STACKER  "32" 

*«*•* 

180A 

REM 

•*•*  CNTRLOPT  »  7  »  POSITIVE  RESPONSE/SELECT  SCANNER  (DC!) 

180A 

REM 

•**•  CNTRLOPT  =  8  =  REQUEST  STATUS  (ESC) 

180A 

REN 

180A 

9010 

REM 

RACP900 
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Offset 

234A 

23S6 

2367 

2370 

238C 

2390 

2390 

2390 

2390 

2390 

2390 

2390 

2390 

2390 

2390 

2390 

2390 

2390 

2391 
2390 
23A4 
2380 
23C6 
2387 
23eB 
23EB 
23EB 
23EB 
23EB 
23EB 
23EB 
23EB 
23EB 
23EB 
23EB 
23EB 
23EB 
23EB 
23EB 
23EC 
23F8 
23FF 
2414 
2430 
2434 
2434 
2437 
2437 
2437 
2437 

2437 

2438 
2440 
2440 


PACK  28 
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Data 

Source  Line 

IBM  1 

180A 

ERRSTATS  >  SPACES(60) 

180A 

CALL  CNTROL  (CNTRLOPT, ERRSTATS) 

160A 

ERRMSGS="" 

180A 

IF  ASCCERRSTATS)  <>  64  THEN  ERRMSGSs«CONTROL  ERROR  "-tERRSTATS 

180A 

GOTO  9100 

180A 

180A 

REM 

»****« 

180  A 

REM 

•***  SUBROUTINE  9020  -  SCAN  SHEET  CALL 

*«•«« 

180A 

REM 

**«« 

***** 

180A 

REM 

*•••  ARGUMENTS:  READTYPE 

***** 

180A 

REM 

*•••  READTYPE  =  2  =  REQUEST  NEW  DOCUMENT  FROM  SCANNER 

***** 

180A 

REM 

**•*  READTYPE  =  3  *  RETRANSMIT  CURRENT  DOCUMENT 

***** 

180A 

REM 

«*«* 

***** 

180A 

REM 

ARGUMENTS:  RECORDLENGTH 

***** 

180A 

REM 

NUMERIC  VARIABLE  SET  TO  THE  NUMBER  OF  CHARACTERS  TO  BE 

***** 

180A 

REM 

*•••  TRANSMITTED 

***** 

160A 

REN 

****** 

180A 

9020 

REM 

180A 

ERRSTATS  s  SPACES<60) 

180  A 

RECORDPTR  =  VARPTR(SHEETREC(0)) 

1S0A 

CALL  SCAN  (READTYPE, RECORDLENGTN,RECORDPTR,ERRSTATS) 

180A 

ERRMSGS="" 

180A 

IF  MI0S(ERRSTATS,14,3)  »  "415“  THEN  ERRMSGS="ESC“ 

180A 

GOTO  9100 

180  A 

180A 

REM 

180A 

REM 

••••  SUBROUTINE  9030  -  TRANSPORT  PRINT  CALL 

***** 

180A 

REM 

***** 

180  a 

REM 

••••  ARGUMENTS:  PRINTPOS 

180A 

REN 

•••*  NUMERIC  VARIABLE  INDICATING  THE  STARTING  PRINT  POSITION 

180A 

REM 

VALUES  =  0  THRU  90 

180  a 

REM 

***** 

180A 

REM 

*•••  ARGUMENTS:  PSTRINGS 

180A 

REN 

TEXT  TO  BE  PRINTED  ON  THE  FORM 

180A 

REM 

*««« 

***** 

180A 

REM 

•••<  NOTE:  THIS  ROUTINE  HAS  NO  EFFECT  UNLESS  THE  SCAM 

180A 

REM 

HEADER  SHEET  IS  MARKED  'PRINTER  ON' 

180A 

REM 

180A 

9030 

REM 

180A 

ERRSTATS  =  SPACES<60) 

180A 

RECORDPTR  =  VARPTR(SHEETREC(0)) 

180A 

CALL  TPR 1 N T (PR  I NTPOS , PSTR I NGS, ERRSTATS) 

1810 

IF  ASC(ERRSrATS)  <>  64  THEM  ERRMSGS="PRIMT  ERROR  "+ERRSTATS 

1810 

GOTO  9100 

1810 

1810 

9100 

RETURN 

1810 

1810 

1810 

REN 

END  OF  SUBROUTINES  ===*========»===»===*=.=================== 

1810 

1810 

25000  REM  USER  TERMINATED  INPUT...  FILE  IS  NOT  TO  BE  USEDII!! 

1810 

LPRIMT  'niSER  TERMINATED  INPUT  ..  DATA  WILL  NOT  BE  USED!" 

1810 

LPRINT  "ERASING  FILE  ";0ATFILS 

1810 

BEEP 

RACP9Q0 

OCC  HEALTH  FORH  OESTRIHG/DECOOE  PROCRAM 


Offset 

Data 

Source  Line 

2451 

1810 

CLS  :  PRINT  iMSER  TERMINATED  INPUT 

245D 

1810 

CLOSE 

2461 

1810 

OPEN  DAT FILS  FOR  OUTPUT  AS  «1 

2473 

1810 

PRINT  «1,STRINGS(RECOROLENGTH.»X*') 

2485 

1810 

CLOSE 

2489 

1810 

2489 

1810 

30000  REN 

248A 

1810 

CLOSE 

248E 

1810 

CHAIN  "RACP10" 

2495 

1810 

2498 

1810 

DATA  UtLL  NOT  BE  USED  I ■ 


•VOID  THE  FIRST  RECORD 
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72151  Bytes  Available 
14906  Bytes  Free 


0  Warning  Errar(s) 
0  Severe  Error(s) 


Offset  Data  Source  Line 
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IBM  Personal  Computer  BASIC  Compiler  ;1.00 


oou 

0002 

REM  SLINESIZE: 

132 

001A 

0002 

REM  SPACES I ZE: 

66 

001A 

0002 

REM  ST I  TIE:  ■RACP910  • 

001A 

0002 

REN  SSUBTITLE: 

•OT  REPEAT  VISIT  FORM 

001A 

0002 

REN  SPACE 

RACP910 

OT  REPEAT  VISIT  FORM 


Offsat 

OOIA 
001A 
OOIA 
OOIA 
OOIA 
001A 
OOIA 
OOIA 
OOIA 
OOIA 
OOIA 
OOIA 
001A 
001A 
OOIA 
OOIA 
OOIA 
001 A 
301A 
001A 
001A 
OOIA 
OOIA 
001A 
OOIA 
OOIA 
OOIA 
OOIA 
OOIA 
OOIA 
001A 
OOIA 
OOIA 
OOIA 
001A 
OOIA 
OOIA 
OOIA 
C31A 
001A 
OOIA 
OOIA 
0''1A 
OOIA 
OOIA 
OOIA 
uOlA 
OOIA 
OflA 
OOIA 
OOIA 
00  lA 
OOIA 
001A 


Data  Sourca  Line 
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0002 

0002 

0002 

0002 

0002 

0002 

0002 

0002 

0002 

0002 

0002 

0002 

0002 

0002 

0002 

0002 

0002 

0002 

0002 

0002 

0002 

0002 

0002 

0002 

0002 

0002 

0002 

0002 

0002 

0002 

0002 

0002 

0002 

0002 

0002 

0002 

0002 

0002 

0002 

0002 

0002 

0002 

0002 

0002 

0002 

0002 

0002 

0002 

0002 

0002 

0002 

0002 

0002 

0002 


REM  . . . 

REM  I  MAME:  RACP910  AMBULATORY  CARE  INFORMATION  SYSTEM  | 

REM  I  DATE:  12  MAR  87  OT  (OHBA)  REPEAT  VISIT  | 

REM  I  D  R  BOLLING  SHORT  FORM  | 

REM  I  I 

REM  I  INCLUDES  PREFIX  TO  LtTHO  FOR  EACH  PATIENT  ON  FORM  | 

REN  . . . 

REN  OT  REPEAT  FORM  INPUT  PROGRAM 

REM 

REM  This  program  reads  the  SHORT  form  OMR  data,  converts  various 
REN  fields,  prints  an  error  report  and  produces  the  file; 

REM 

REM  VISIT.DAT 

REN 

REM  for  input  to  FOCUS.  NOTE  THAT  THIS  FILE  IS  OPENED  FOR  APPEND 
REM  each  time  the  program  is  run.  Thus,  if  the  file  does  not  exist, 

REM  records  will  be  added  to  the  front.  If  the  file  exists,  records 
REM  uill  be  added  to  the  end  of  the  current  file.  It  is  intended  that 
REM  the  FOCUS  DIALOGUE  MANAGER  ROUTINE  which  loads  the  data  will  delete 
REM  the  data  file  after  the  load  has  been  successfully  accomplished. 

REM 

REM 

REN  If  there  is  no  valid  user  logged  at  the  time  of  execution,  this 
REN  program  will  chain  to  the  logon  program  RXXPOS,  otherwise, 

REM  THE  PROGRAM  CHAINS  TO  PROGRAM  RACP10  ON  EXIT. 

REM  SINCLUDE:  'RACOIM.MQO'  REN  INCLUDE  THE  DIMENSION  DEFINITIONS 

t*«*«*««***«*«***e*«***M**********4H»********************************** 

'*  NAME:  RACOIM.NOD  DIKNSION  DEFINITIONS  * 

'*  Date;  28  Feb  84  Written  by;  Floyd  Cole  • 

'  Dimensioned  variables  are  defined  in  this  file. 

'  It  is  an  included  file  so  it  cannot  be  run  in  a  stand-alone, 

'  mode. 


This  program  segment  may  be  modified,  but  all  files  containing 
an  include  for  this  segiaent  must  be  re-conpiled  in  order  to 
affect  the  changes  made  here. 

•••***.**•••  start  of  dimension  definition  *•***•*••*•*•••••••' 


DEFINT  A-Z 

DIM  USER$(2),HOLENGTH(12),OATEERR$(3) 
•*•••••*••**  END  OF  DIMENSION  DEFINITIONS 


REM  DIMENSION  STATEMENTS  UNIQUE  TO  THIS  PROGRAM 


DIM  SHEETREC<1730) 
DIM  PROTOCOL(7) 

DIN  E0.NSGS(30) 

DIN  CLINIC2.PFX$(6} 
DIM  PROCED$(26) 

DIM  PROVIDER. TIMESIS) 


■(MAX.  SIZE  FOR  A  SHEET  FROM  THE  SCANNER) 
'(ARRAY  FOR  SERIAL  BOARD  SETUP  PARAMETERS) 
’(ERROR  MESSAGES  FROM  EDIT  ROUTINES) 
'(PREFIX  -A  B  C  0  F  S-  FOR  CLINIC  #2) 
■(PROCEDURE  TABLE  FOR  SHORT  FORM) 
'{PROVIDER  TIME  TABLE) 


»  -i 

M 


4 

— 1 


.1 


( 


RACP910 
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DIM  REFCOOSdS) 
DIM  VDATS<4) 

DIM  PR1.COOS(4) 
DIM  PR1.TIMS(4) 
DIM  PR2.COO$<4) 
DIM  PR2.TIMS(4) 
DIM  SPROV.REAS<4) 
DIM  VIS.CNT$(4) 
DIM  TOT.PROC1(4) 
DIM  TOT.PROC2(4) 
DIM  GR0UP1S(6,27) 
DIM  GROUP2S(6,26) 
DIM  HOLOS<26) 


•(REFERRAL  CODE  TABLE) 


ARRAYS  TO  HOLD  MULTIPLE  VISITS 


•(PATIENT/PROCEOURE  GROUP  PfiOV  1) 
■(PATIENT/PROCEDURE  GROUP  PROV  2) 
•(HOLD  AREA  FOR  SUBROUTINE  6000) 


REM  SINCLUOE:  'RACCMN.MOO*  REM  INCLUDE  THE  COMMON  AREA  DEFINITION 


*  NAME:  RACCMH.MOO 

*  Date:  28  Feb  84 


COMMON  AREA  DEFINITION 
Written  fay:  Floyd  Cole 


COMMON  AREA  DEFINITIONS  WILL  BE  HELD  IN  THIS  FILE.  IT  IS  AN 
INCLUDED  FILE  SO  IT  CANNOT  BE  RUN  IN  A  STAND*ALONE.  MODE. 


This  program  segment  may  be  modified,  but  all  files  containing 
an  include  for  this  segsient  laust  be  re*compiled  in  order  to 
affect  the  changes  made  here. 


••••••"•••••START  OF  COMMON  DEFIMITIONS^^^^^^^^^^^^^^^^^^^^"^^ 


COMMON  FORE, BACK, BOARD, HIDE, EFORE.EBACK, BELLS  'BASIC  SCREEN  COLORS 


COMMON  HEADERS 


COMMON  TEXTS  ••  AINING  CHAR 

COMMON  PGMIDS  'PROGRAM  OR  FORI 

COMMON  MOLENGTHO  'DAYS  IN  THE  MONTH 

COMMON  USERSO 

•••••••••••••END  OF  COMMON  DEFINITION 


•21  CHARACTER  SCANNER  HEADER  INFO 
"  AINING  CHARACTERS  FROM  SCANNER 
•PROGRAM  OR  FORM  ID 


REM  SINCLUDE:  'RACOEF.MOO' 


REN  INCLUDE  THE  DEFAULT  DEFINITIONS 


NAME:  RACPOI.DEF 
Date:  28  Feb  84 


DEFAULT  DEFINITIONS 
Written  by:  Floyd  Cole 


Variables  used  in  cannon  that  have  a  default  value  on  start-up 
will  be  held  in  this  file.  It  is  an  included  file  so  it  cannot 
be  run  in  a  stand-alone  mode.  In  normal  operation,  this  file 
should  be  'included'  in  the  main  program  only  (RACP10.BAS). 


This  program  segment  may  be  modified,  but  all  files  containing 
an  include  for  this  segment  nust  be  re-compiled  in  order  to 
affect  the  changes  made  here. 


•START  OF  DEFAULT  DEFINITION- 


FORE  s  15 


•FOREGROUND  COLOR  s  INTENSE  WHITE 


UCP910 

or  REPEAT  VISIT  FORM 
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0050 

1654 

BACK  >  1 

Background  Color  ■  Light  Blue 

0057 

1654 

BORO  «  4 

BORDER  >  RED 

005E 

1656 

HIDE  >  4 

ALTERNATE  COLOR  >  RED 

0065 

1656 

EFORE>  14 

ERROR  FOREGROUND  OISPUY 

006C 

1656 

EBACX>  0 

ERROR  BACKGROUND  DISPLAY 

0073 

1656 

BELLS  >  CHRS<7) 

'Soutd  the  bell 

007F 

1656 

007F 

1656 

HOLENGTH(I) 

m 

31  'JAN 

0086 

1656 

H0LENGTH(2) 

m 

28  'FEB  <-NCOIFtEO  IN  SUBROUTINE  RACS5000 

0080 

1656 

M0LENGTH(3) 

M 

31  'MAR 

0094 

1656 

H0LENGTH(4) 

m 

30  'APR 

0098 

1656 

M0LENGTH(5) 

m 

31  'HAY 

OOA2 

1656 

M0LENGTH(6) 

m 

30  'JUN 

OOA9 

1656 

M0LENGTH(7) 

m 

31  'JUL 

0080 

1656 

N0LENGTH(8) 

m 

31  'AUG 

0087 

1656 

M0LENGTH(9) 

m 

30  'SEP 

OOBE 

1656 

HOLENGTH(IO) 

m 

31  'OCT 

OOC5 

1656 

H0LENGTH<11) 

m 

30  'NOV 

OOCC 

1656 

M0LEMGTH(12) 

m 

31  'DEC 

0003 

1656 

0003 

1656 

OATEERRtIO) 

m 

m  M 

OOOC 

1656 

DATEERRS(I) 

m 

"INVALID  MONTH" 

C0E5 

1656 

DATEERRS(2) 

m 

■INVALID  DAY  ■ 

OOEE 

1656 

0ATEERRS(3) 

M 

■DAY  TOO  LARGE  FOR  MONTH  COOED" 

00F7 

1656 

00F7 

1656 

HAXLENGTH 

9 

80  'MAXIMUM  LENGTH  OF  OUTPUT  RECORD 

OOFE 

1658 

PADS 

m 

'PAD  CHARACTER  FOR  SHORT  RECORDS 

0107 

165C 

0107 

165C 

1  ••*••**•*••••£110  OF  DEFAULT  DEFINlTIOM***«****»»**********»»» 

0107 

165C 

0107 

165C 

0107 

165C 

ICEY  OFF 

0100 

165C 

C100 

165C 

REH  •••••♦•••••* 

*«• 

0100 

165C 

REH  THE  FOLLOWING  VARIABLES  ARE  UNIQUE  TO  EACH  PROGRAH  AND  MUST 

0100 

165C 

REH  BE  CHANGED. 

0100 

165C 

0100 

165C 

PGHTITLS 

«  "OT  (DHBA)  REPEAT  FORM" 

0116 

1660 

0116 

1660 

PGMIDS  • 

"910“  'VALUE  RECEIVED  FROM  THE  SCANNER 

011F 

1660 

'IN  HEADER  VARIABLE  'PROGRAMS' 

011F 

1660 

011F 

1660 

DATFILS 

"VISIT.OAT"  'FILE  TO  BE  INPUT  TO  FOCUS 

0128 

1664 

0128 

1664 

REH  LENGTH  OF  STRING 

RECEIVED  FROM  THE  OMR.... 

0128 

1664 

HEADER  > 

21 

OlcIF 

1666 

RESPONSE* 

331 

0136 

1668 

RECOROLENGTH 

"  HEADER  *  RESPONSE 

141 

166A 

0141 

166A 

N.PROC 

26 

'  NUMBER  OF  PROCEDURES  FOR  THIS  FORM 

0H8 

166C 

0148 

166C 

REM  •••••*••*••' 

»**•* 

ona 

166C 

UU8 

166C 

8TIME$=TIME$ 

'SCAN  START  TIME 

RACP910 

OT  REPEAT  VISIT  FORM 
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0151  1670 

0151  1670 

0151  1670  REM  ENCOUNTER  FORM  CLINIC  PREFIX  TABLE 

0151  1670  REM  CLINIC  #2 

0151  1670  CLINIca.PFXSfOle"  •• 

015A  1670  CLINIC2.PFXS(1)«»A“ 

0163  1670  CLINIC2.PFXS(2)>‘*B« 

016C  1670  CL1NIC2.PFXS<3)>'‘C« 

0175  1670  CLINlC2.PFXS(4)e"0'* 

017E  1670  CLIN1C2.PFX$(S)’>>‘F» 

0187  1670  CL1NIC2.PFXS(6)=''S'' 

0190  1670 

0190  1670  REM  •**  PREASSIGNEO  REFERRAL  COOES  •** 

0190  1670  REFC00$(1}««AAAA"  :  REFC00$(07)«“AFYC“  :  REFC00S(13)-“BGYA“ 

01AB  1670  REFCQ0$(2)»"AAAF"  ;  REFCO0$<08)="BAAA"  :  REFCOO$(14)»"BHAE" 

01C6  1670  REFCOOSISI^XABAA*  ;  REFCOOSIOOI^-BBAA"  :  R£FCOOS(1S>>"BHAF>> 

01E1  1670  REFC00$<4)««AB0A"  :  REFCODSdOI'^BBCA"  :  REFC00$(16)«“BHAG“ 

01FC  1670  REFCOOS(5)««AEAA"  ;  REFC00S<11 )«"B0AA“  :  REFCOO$(17)«"B1YA« 

0217  1670  REFCOOS(6)»"AFYA"  :  REFCOO$(12)»«BEAA"  :  REFCOO$(18)«“OMOA" 

0232  1670 

0232  1670  REM  •**  ENCOUNTER  FORM  PROCEDURE  TABLE 

0232  1670  PROCEDS(0)>«  ■  :  PROCED$<10)  »  •■04224"  :  PROCED$(20)»  *04125“ 

0240  1670  PROCEOS(1)«“04215“  ;  PROCEO$<11)  «  "04184"  :  PROCEDS(21)e  "04227“ 

0268  1670  PROCE0$(2)=“04214"  :  PROCED$(12)  «  “04104"  :  PROCEDS(22)*  "04085" 

0283  1670  PROCE0${3)»“04213"  :  PR0CE0$<13)  ■  “04129“  :  PROCED$(23)«  "04087" 

029E  1670  PROCEDS(4)«"04136"  :  PROCEOS(14)  «  "04094"  :  PROCED$(24)«  *04194" 

02B9  1670  PR0CE0$<5)«"04192"  :  PR0CE0$<15)  »  "04208*  :  PROCEDS<25)»  “04126" 

0204  1670  PROCE0S(6)="04092"  :  PROCEDS(16)  «  "04207"  :  PROCED$(26)>«  “04127" 

02EF  1670  PR0CE0S<7)*“04128"  :  PR0CEDS<17)  «  “04186" 

0301  1670  PROCEDS(8)>"04229"  :  PR0CED$(18)  »  "04185“ 

0313  1670  PR0CED$(9)="04196"  :  PR0CED$(19)  =  "04095" 

0325  1670 

0325  1670  REM  *•*  PROVIDER  TIME  TABLE  **• 

0325  1670  PROVIDER. TIME$(00)="000“  '  NO  TIME 

032E  1670  PROVIDER. TIMES(01)="005“  •  5  MINUTES 

0337  1670  PROVIDER. TIME$<02)="010"  '10  MINUTES 

0340  1670  PROVIDER. TIME$(03)»"015“  '15  MINUTES 

0349  1670  PROVIDER. TIME${04)=“020"  '20  MINUTES 

0352  1670  PROVIDER. TIME$<05)="030“  '30  MINUTES 

035B  1670  PROVIDER. TIMES(06)*"045“  >45  MINUTES 

0364  1670  PROVIDER. TIME$(07)=“060"  '60  MINUTES 

0360  1670  PROVIDER. TIME$(08)="999"  ■  >  1  HOUR 

0376  1670 

0376  1670  REM  INCLUDE:  'UCABAMC.OPT'  INCLUDE  OUTPATIENT  UCA  TABLE 

0376  1670 

0376  1670  REM  SPAGE 
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0376 

1670 

037B 

1670 

037F 

1670 

0384 

1670 

0384 

1670 

0384 

1670 

0384 

1670 

0384 

1670 

0384 

1670 

0396 

1670 

0396 

1670 

0396 

1670 

0396 

1670 

0396 

1670 

03A1 

1670 

.T3AB 

1670 

0387 

1672 

03BE 

1672 

03D3 

1672 

03E9 

1672 

03E9 

1672 

03E9 

1672 

03E9 

1672 

03E9 

1672 

03E9 

1672 

03EE 

1672 

0408 

1676 

0408 

1676 

U08 

1676 

0414 

1678 

042E 

1678 

042E 

1678 

9443 

1678 

044A 

167A 

044A 

167A 

C44A 

167A 

044A 

167A 

044A 

167A 

044A 

167A 

0'>4A 

167A 

044B 

167A 

044B 

167A 

9454 

167E 

046A 

167E 

046A 

167E 

0  6F 

167E 

048B 

1682 

04  "8 

1682 

04)4 

1682 

0499 

1682 

049E 

1682 

9443 

1682 

04u5 

1686 

0481 

1686 

GOSUB  1000  'MAKE  SURE  THEY  ARE  LOGGED  ON 

CLS 

GOSUB  7000  'PRUT  SCREEN  HEADING 


REH 

OPEN  OATFILS  FOR  APPEND  AS  «1 


LPRINT  CHRS(IS); 

WIDTH  •LPT1:",160 

PAGE  >  0  :  GOSUB  7100  'LINE  PRINTER  HEADING 
COLOR  14 

LOCATE  11.26  :  PRINT  *0T  REPEAT  FORM  " 

COLOR  FORE, BACK, BORO 

PEM  •**«**««*«**«**««*««*•**«««*««««**««*««**«*••****•*•«*•«««**•*«***• 

REM  ••••  COMMUNICATIONS  SETUP  ***• 

**«*****•*****«*****«*****«*****************«*««*•*•«******••**•*** 

REH  PROTOCOL 
GOSUB  9001 

IF  ERRHSGS  >  ■  «  THEN  LPRINT  ERRHSCS  :  GOTO  30000 

REM  START  SCANNER  (SI) 

CNTRLOPT  >1  :GOSUS  9010 

IF  ERRHSGS  >  «  "  THEN  LPRINT  ERRHSGS  :  GOTO  30000 

LOCATE  22,25:PRINT  "PRESS  'ESC>  TO  TERMINATE  SCANNING  " 

READTYPE»3  'FIRST  TIME  IN..  SCANNER  IS  STARTED.. 

e****************************************************************** 
REM  ••••  SET  SCAN  SHEET  CALL 

REM 
REH 

10  REM  -  RETURN  POINT  TO  READ  NEXT  SHEET 


A$= INKEYS 

IF  ASsCHRS(27)  THEN  GOTO  25000 

GOSUB  9020  'SCAN  SUBROUTINE  •  GET  A  RECORD 

IF  MI0S<ERRSTATS,14,3)»"415"  THEN  GOTO  25000 

TEXTS*""  'CLEAR  THE  INPUT  AREA 

GOSUB  8000  'DECODE  HEADER 

GOSUB  8050  'CHECK  FOR  ENO  OF  JOB/ENO  OF  BATCH 

GOSUB  8200  'DECODE  THE  RESPONSE  POSITIONS 

LITHOS  »  MIDS(TEXTS,22,8) 

GOSUB  8070  'CHECK  FOR  SCANNER  ERRORS 
GOSUB  8100  'PRINT  THE  DATA  OH  THE  SCREEN 


RACP910 
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Offset 

Data 

Soul 

04BF 

1686 

04BF 

1686 

04BF 

1686 

REM 

04SF 

1686 

REM 

04BF 

1686 

REM 

04BF 

1686 

REM 

(KBF 

1686 

REM 

04BF 

1686 

REN 

04SF 

1686 

REM 

OABF 

1686 

REM 

04BF 

1686 

REM 

04BF 

1686 

REM 

04BF 

1686 

REM 

04SF 

1686 

04BF 

1686 

04C6 

1688 

0AC6 

1688 

REM 

(KC6 

1688 

04C6 

1688 

REN 

(KC6 

1688 

100 

04CF 

i6ac 

OACF 

168C 

REM 

OACF 

168C 

102 

04E1 

1690 

(KF3 

1694 

0AF3 

1694 

REM 

04f3 

1694 

104 

OSOS 

1698 

0513 

1698 

0520 

169A 

0532 

169E 

0536 

169E 

0536 

169E 

106 

054C 

169E 

0S6E 

169E 

0S6E 

169E 

REM 

0S6E 

169E 

108 

0584 

169E 

0598 

16A2 

OSAC 

16A2 

OSCO 

16A2 

0SD2 

16A2 

05E0 

16A2 

OSEO 

16A2 

05E0 

16A2 

110 

060F 

16A2 

060F 

16A2 

112 

061E 

16A6 

064A 

16A6 

065C 

16A6 

065C 

16A6 

066A 

16A6 

0672 

16A6 

0686 

16A6 

PAPE  7 
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REM  SIMCLUDE:  ‘RACMOIO.MOI •  INCLUDE  THE  REPEAT  FORM  REFORMAT/EDIT  MOO 

***********************««******«»«««*««««*««««««— 

*•••  AMBULATORY  CARE  INFORMATION  SYSTEM  12  MAR  87  *••• 

•***  0  R  BOLLING  •••• 

MODULE  NAME  RACM910.M01  •*** 

***•  SCANNER  PROGRAM  «  :  910-  OT  REPEAT  VISIT  FORM  *••• 

*•**  **.* 

****  PURPOSE  ;  REFORMAT/EDIT  THE  ENCOUNTER  *••• 

****  SHORT  FORM  OMR  RECORD. 

********»**********«**********#**^hhm»*********«*********#*********« 

****  RESERVED  LINE  NUMBERS  100-199  **** 

**************** ****»******»»*»*»**»»»***»#»«oa«*»»»*»<i»»»»»»»»»»#» 

N-ERR  >0  'COUNTS  THE  NUMBER  OF  ERRORS 

***  LITHO  CODE  DONE  IN  BAS  PROGRAM  •** 

•**  CLINIC  ID 

CLl.COO$»"OHBA"  'DEFAULT  aiNIC  CODE 

***  SSN  AND  FMP  *•* 

SSNS»MIDS<TEXTS,30,9) 

FMEMP»«MI0$( TEXTS,  39, 2) 

REFERRAL  CODE  ••• 

XS»MID$(TEXT$,A1,2)  'SINGLE  BUBBLE  CODE 

IF  XS-"  «  THEN  106 

X-VAL(XS) 

REF.COOS<REFCCO$(X)  'USE  TABLE 
GOTO  10S 

X=VAL(MI0${TEXT$,43,1)) 

REF.C00$»CLINIC2.PFX$(X)  ♦  MI0$(TEXTS,44,3) 

•••  UNLISTED  OX 
X=VAL<MID$(TEXT$,47,1)) 

IF  X=0  THEN  PRIMOXS*"" 

IF  X=1  THEN  PRIHDX$="V'' 

IF  X=2  THEN  PRIMOXSs"S" 

X$=MID$<TEXT$,48,5) 

IF  X$=''  "  THEN  112 

REM  ...  REMOVE  LEADING  BLANKS  ... 

IF  LEFT$(XS,1)="  "  THEN  XEsRIGHTSCXS,*)*"  '•;GOTO  110 

LASTC$=RIGHT$(X$,1)  'GET  LAST  CHAR 

IF  LASTCSo"  "  AND  LASTC$<>"0"  THEN  PRIMOXS*""  'REMOVE  V  OR  S 
PRIMOXS=LEFTS<PRIMOX$+X$,5)  'GET  5  CHAR  ONLY 

IF  PRIMOXSo"  "  THEM  113 
N.ERR>N.ERR>1 

ED.MSG$<M.ERR)="N0  DIAGNOSIS  COOED" 
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0686  16A6  113  REM 

0687  16A6  DAT.OFFSET  >  53 

068E  16A8  PFX.OFFSET  >  57 

0695  16AA  PR1 .OFFSET  >  58 

069C  16AC  PRT. OFFSET  «  62 

J6A3  16AE  P2X.OFFSET  >  63 

06AA  1680  PR2.0FFSET  a  64 

06B1  1682  P2T. OFFSET  >  68 

0688  1684  REA.OFFSET  >  69 

06BF  1686  VCT.OFFSET  ■  70 

06C6  1688  UPR.OFFSET  a  71 

06C0  168A  PRC.OFFSET  a  76 

0604  16BC  PC2.0FFSET  a  102 

0608  168E  TOT. OFFSET  a  75 

06E2  16C0  POINTER  a  Q 

06E9  16C2 

06E9  16C2  CMSaNI0$(0ATES,1,2)  ‘CURRENT  MONTH 

06FB  16C6  FOR  1910  >  I  to  4  ‘INITIALIZE  VISIT  OATE  ARRAY 

1)702  16C6  VDAT$<I910)  a  a  a 

0716  16l8  next  1910 

0725  16C8 

0725  16C8  REM  **•  REPEAT  THE  FOLLOUING  CODE  4  TIMES 

0725  16C8  FOR  1910*  1  TO  4 

072C  16C8 

372C  16C8  REM  ***  VISIT  OATS  *** 

r72C  16C8  YR$aMI0$<0ATES,9,2)  'CURRENT  YEAR 

073E  16CC  X$=MIO$<TEXT$,DAT.OFFSET+POINTER,4)  ‘MONTH  AND  DAY  FROM  FORM 

0755  16CC  IF  XSa"  "  THEN  199  ‘TIME  TO  QUIT 

0763  16CC  IF  LEFT$(XS,2)<aCH$  THEN  116  ‘OK.  USE  THIS  YEAR 

C778  16CC  YRS=RIGHT$(STR$(VAL(YR$)-1),2)  ‘USE  LAST  YEAR 

0798  16CC  116  VDATES  *  yRS  *  X$ 

07A6  1600  ‘EDIT  VISIT  OATE 

07A6  1600  CX.5000$=VDATE$ 

07AF  1604  GOSUB  5000  ‘DATE  CHECK 

0784  1604  CK.5010$aVDATES 

C^D  1608  GOSUB  5010  ‘NUMERIC  STRING  CHECK 

07C2  1608  IF  RT.5000  =  0  AND  RT.5010  *  0  THEM  GOTO  118 

07E6  160C  N.ERR*N.ERR*1 

O/EE  160C  EO.MSC$<M.ERR)='‘TOOAYS  DATE  "  ♦  DATEERRt<RT.5000) 

0814  160C 

0814  160C  118  VDAT$(I910)=VOATE$ 

T828  160C 

0828  160C  REM  PROVIDER  1  ID  (PREFIX  ♦  NUM)  ••• 

0825  160C  120  PROVI.PFXS  *  MID$(TEXT$,PFX.OFFSET+POIMTER,1) 

TOSF  16E0  PROVl.NUMS  *  MI0$(TEXT$,PR1 .0FFSET+P0INTER,4) 

0156  16E4  PR1.C00S(I910)=PROV1.PFX$  ♦  PROVl.NUMS 

036F  16E4 

086F  16E4  REM  **•  PRIMARY  PROVIDER  TIME 

08cf  16E4  121  X=VAL(HID$(TEXT$,PRT.OFFSET+POINTER,1)) 

088A  16E4  PR1.TIM${I910)=PR0VI0ER.TIME$(X) 

C5A7  16E4 

08A7  16E4  REM  PROVIDER  2  ID  (PFX  ♦  NUM)  ••• 

C2A7  16c4  122  PROV2.PFX$  =  MIOS(TEXT$,P2X.OFFSET*POINTER,1> 

083E  16f8  PROV2.NUMS  =  “TDtl TEXTS, PR2.0FFSET*POINTER,4) 
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080S  16EC  PR2.COOS(I910)>PROV2.PFX$  *  PROV2.NUMS 

OBEE  16EC  IF  PR2.COOS(I910)>>'‘  ■■  THEN  PS«1  ELSE  PB«0  'PROVE  BLANK  INC 

0917  16EE  IXS>STRS(I910) 

0924  16F2  IF  PROVE. PFXS>«  ■  AND  PROVE. NUMSo"  THEN  124 

094A  16F2  IF  PROVE . PFXSo"  ••  ANO  PROVE. NUMS^"  ■*  THEN  124 

0970  16F2  GOTO  125 

0974  16F2 

0974  16F2  124  N.ERR  >  N.ERR  *  1 

097C  16F2  ED.MSG$(N.ERR):''PROV  2  CODE  MISSING  PREFIX  OR  NUMBER  IN  PART"+IXS 

0995  16F2 

0995  16F2  REM  •**  SECONDARY  PROVIDER  TIME  *•* 

0995  16F2  125  X>VAL(HID$(TEXTS.P2T.0FFSET'''POINTER,1)) 

0980  16F2  PR2.TIMS(I910)>PROVIOER.TIMES(X) 

09CO  16F2  REM  IS  THERE  A  TIME  ANO  NO  SEC  PROV  COOED? 

09CO  16F2  IF  PR2.TIMS(I910)<>“000«  ANO  PB>1  THEN  126 

09FA  16F2  REM  IS  THERE  NO  TIME  ANO  A  SEC  PROV  COOED? 

09FA  16FE  IF  PR2.TIH$<I910)x"000"  ANO  PB*0  THEN  127 

0A27  16F2  GOTO  128 

0A2B  16F2 

0A2B  16F2  126  N.ERR  «  N.ERR  *  1 

0A33  16F2  E0.NSG$(N.ERR)'!''TIME  COOED  WITH  NO  SEC  PROV  COOED  IN  PART''+IXS 

0A4C  16F2  GOTO  128 

0A50  16F2 

0A50  16F2  127  N.ERR  «  N.ERR  ♦  1 

0AS8  16F2  EO.MSGS(N.ERR)**'<NO  PROV  2  TIME  IN  PARTo+tXS 

0A71  16F2 

0A71  16F2  REM  REASON  FOR  «2  CARE  PROVIDER  ••• 

0A71  16F2  128  SPROV.REAS<I910)=MIOS{TEXTS,REA.OFFSET+POINTER,1) 

0A94  16F2  REM  IS  THER  A  REASON  ANO  NO  SEC  PROV  COOED? 

0A94  16F2  IF  SPR0V.REA$(I910)<>"  "  ANO  PB»1  THEN  129 

OACI  16F2  REM  IS  THERE  NO  REASON  ANO  A  SEC  PROV  COOED? 

0AC1  16F2  IF  SPROV.REA$<I9tO)*"  "  ANO  PB=0  THEN  130 

OAEE  16F2  GOTO  131 

0AF2  16F2 

0AF2  16F2  129  N.ERR  *  N.ERR  ♦  1 

OAFA  16F2  ED.HSG$(N.ERR)<"REASON  COOED  WITH  NO  SEC  PROV  COOED  IN  PARIx^^IXS 

0B13  16F2  GOTO  131 

0817  16F2 

0817  16F2  130  N.ERR  *  N.ERR  *  1 

0B1F  16F2  ED.MSGS(N.ERR)>"NO  PROV  2  REASON  IN  PART»«IXS 

0838  16F2 

0838  16F2  REM  ***  VISIT  COUNT 

0838  16F2  131  VCNT$="1“  'DEFAULT 

0841  16f6  XS*MIOt<TEXT$,VCT.OFFSET+POIMTER,1) 

0858  16F6  IF  X$="1"  THEN  VCNT$="0" 

0B6F  16F6  IF  X$>"1"  THEN  VCNTS=XS 

0886  16F6  VIS.CNTS(I910)=VCNTS 

0B9A  16F6 

0e9A  16F6  REM  ***  ADDITIONAL  PROCEDURE 

0B9A  16f6  132  AOOP$=MIO$<TEXT$,UPR.OFFSET*POINTER,5) 

0881  16FA 

0881  16fA  REM  PROCEDURE  COOES  FOR  PROV  1 

0881  16fA  134  X$  »  MID$(TEXT$,PRC.OFFSET+POIMTER,N.PROC) 

0BC9  16FA  GOSUB  6000  'DECODE  THE  XS  STRING 
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OSCE 

16FA 

0800 

16FC 

OBEA 

16FE 

OCOO 

1702 

0C22 

1702 

0033 

1702 

0C33 

1702 

0C33 

1702 

0C41 

1702 

0C49 

1702 

0C62 

1702 

TC62 

1702 

0C71 

1702 

0C71 

1702 

CC71 

1702 

0C89 

1702 

0C8E 

1702 

0C9O 

1702 

CCA8 

1702 

OCBS 

1704 

OCCB 

1704 

OCEO 

1704 

OCFE 

1704 

OCFE 

1704 

IDOO 

1704 

0O11 

1704 

0011 

1704 

0019 

1704 

0032 

1704 

0032 

1704 

0030 

1704 

0O4F 

1704 

OOiO 

1704 

0050 

1704 

050 

1704 

0050 

1704 

0050 

1704 

OOJF 

1704 

0)71 

1704 

jon 

1706 

0D8A 

1708 

OOAO 

1708 

DDB1 

1708 

OUBO 

170A 

0OC4 

170A 

«C9 

170A 

OOCO 

170A 

00. D 

170A 

OOCE 

170A 

UOCF 

170  A 

OCCE 

170A 

JOCE 

170A 

COlE 

170A 

V.OCE 

17CA 

IF  TOT  >  0  THEN  GOTO  135 
FOR  1910.A=  1  TO  TOT 
PTR>VAL(HOL0S(1910.A)) 
GROUP1S<l910,l910.A)aPROCEDS(PTR) 

NEXT  1910. A 

REM  ...  ADO  UNLISTED  CODE  IF  THERE  TO  PROV  1  ... 

135  IF  ADOPtao  >  THEN  138 
TOT»TOT+1 

GR0UP1S(I910.TOT)>AD0PS 

136  TOT.PROC1(I910)«TOT 

REM  **•  PROCEDURE  COOES  FOR  PROV  2 

138  XS  °  MtDS(TEXTS,PC2.OFFSET+POINTER,N.PR0C) 

GOSUB  6000  'DECODE  THE  XS  STRING 

IF  TOT  «  0  THEN  GOTO  140 

IF  PB«1  THEN  141  'ERROR  IF  PROV  2  CODE  BLANK 

FOR  I910.A*  1  TO  TOT 
PTRaVAL(HOL0S(I910.A)) 

GROUP2S( 1910, 1910. A)°PROCEOS(PTR) 

NEXT  I910.A 

140  TOT.PROC2(I910)«TOT 

GOTO  142 


141  N.ERR  =  N.ERR 

ED.MSGS{H.ERR)="PROC  FOR  SEC  PROV  BUT  NO  SEC  PROV  COOED  IN  PART>'+IX$ 

142  POINTER  =  POINTER  +  TOT. OFFSET 
NEXT  1910 

199  REM 

REM  . ENO  OF  MODULE  RXXM910.M01 . 


IF  N.ERR  »  0  THEN  GOTO  997 
LPRINT  "LITHO  »  “.-LITHOS;"  ...  ERRORS" 

FOR  1997  =  1  TO  N.ERR 
LPRINT  USING  "###  ";I997; 

LPRINT  ««>  ";E0.MSG$<I997) 

NEXT  1997 

LN. COUNT  >  LN. COUNT  *  N.ERR  *  1 
CNTRLOPT  >  6 

GOSUB  9010  'REJECT  THE  FORM 

GOTO  998  'BYPASS  THE  DISK  WRITER _ 

997  REM  SINCLUDE:  'RACM910.M02'  REM  INCLUDE  THE  BASE  ENCOUNTER  FORM  DISK  WRITER 
REM 

REM  •••* 

REM 
REM 
REM 

REM  **** 


AMBULATORY  CARE  INFORMATION  SYSTEM  13  MAR  87 

0  R  BOLLING 

MODULE  NAME  :  RACM910.MO2 

SCAK'.TF  PROGRAM  »  :  910-  OT  REPEAT  VISIT  FORM 


•  *** 


RACP910 
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Offset  Data  Source  Line 

OOCE  170A  REM  •••*  PURPOSE  :  CREATE  AMO  WRITE  THE  DISK 

OOCE  170A  REM  RECORD  FOR  INPUT  TO  FOCUS  •••• 

OOCE  170A  REM  ***• 

OOCE  170A  REM  PROGRAM  ADOS  PREFIX  TO  LITHO  FOR  EACH  PATIENT 

OOCE  170A  REM 

OOCE  170A  REM  **•*  RESERVED  LINE  NUMBERS  200-299  *••• 

OOCE  1 70A  REM  •****«*«•«*«•****«*•*«••*******««••«*••*«••***•*«•**«***•«***•*•**• 

OOCE  170A 

OOCE  170A  REM  BUILD  THE  OUTPUT  RECORD 

OOCE  170A 

OOCE  170A  REM 

OOCE  170A  REM 

OOCE  170A  REM 

OOCE  170A  REM 


OOCE 

170A 

OOCE 

170A 

REM 

...  TYPE  1  RECORD  ... 

OOCE 

170A 

OOCE 

170A 

FOR  IK  ■  1  TO  4 

ODDS 

170A 

RECKEYS  •  CL 1. COOS  ♦  VDATt(IK)  «PR1 .COOS(IK)  *  SSNS  *  FMEMPS 

0E03 

1710 

IF  VOATS(IK)  »  «  ■  THEN  240 

0E10 

1710 

RECOUTS  «  ''9101'*  ♦  RECKEYS  ♦  RIGHTS(STRS(tK),1)  ♦  RIGHTS(LITH0S,7) 

0E40 

1714 

TYPE1S  «  ■•91"  ♦  VIS.CMTS<IK)+PR1.TIMS(IK)+PR2.CQ0S<IK)+PR2.TIMS(tK) 

0E91 

1718 

TYPE1AS*  SPROV.REASLIK)  ♦  »  »  ♦  REF. COOS  ♦  STRINCSdl,*  ")  ♦  PRIMOXS 

0EC2 

171C 

RECOUTS  *  RECOUTS  ♦  TYPE1S  ♦  TYPEIAS 

OEOS 

171C 

GOSUB  280 

OEOA 

171C 

PRINT  «1, RECOUTS 

OEES 

171C 

240 

NEXT  IK 

0EF7 

171C 

0EF7 

171C 

REM 

0EF7 

171C 

REM 

RECORD  TYPE  "2"  -  RECKEY  PLUS  PROCEDURE  CODE 

0EF7 

171C 

REM 

0EF7 

171C 

REN 

RECOUTS  *"9102"*RECKEYS  'TRANSACTION  IDENTIFIER 

0EF7 

171C 

0EF7 

171C 

REN 

...  PROCEDURES  OF  FIRST  PROVIDER  ... 

0EF7 

171C 

0EF7 

171C 

FOR  1910  »  1  TO  4 

OEFE 

171C 

FOR  1910. A  «  1  TO  T0T.PROC1<I910) 

0F12 

171E 

RECKEYS  =  CLI.COOS  ♦  VDATS<I910)  ♦PR1 .COOS<I910)  ♦  SSNS  ♦  FMEMPS 

0F42 

171E 

IF  VDATS(I910)  *  "  «  THEN  250 

0F5A 

171E 

RECOUTS  •  “9102'*  ♦  RECKEYS  ♦  RICHTS<STRS(I910),1)  ♦  RIGHTSILITHOS,?) 

0F8A 

171E 

RECOUTS  sRECOUTS  ♦  "911"  ♦  GR0UP1S< 1910, I910.A) 

OFAE 

171E 

GOSUB  280 

0FB3 

171E 

PRINT  #1, RECOUTS 

OFBE 

171E 

NEXT  1910. A 

0F02 

171E 

250 

NEXT  1910 

0FE4 

171E 

0FE4 

171E 

REM 

...  PROCEDURES  OF  SECOND  PROVIDER  ... 

0FE4 

171E 

0FE4 

171E 

FOR  1910  «  1  TO  4 

0FE8 

171E 

FOR  1910. A  =  1  TO  TOT.PROC2(I910) 

OFFF 

1720 

RECKEYS  *  CLI.COOS  ♦  VDATS(I910)  ♦PRi .C0OS(I910)  ♦  SSNS  ♦  FMEMPS 

102F 

1720 

IF  VOATS(I910)  =  “  "  THEN  260 

1047 

1720 

RECOUTS  =  "9102"  ♦  RECKEYS  ♦  RICHTS(STR$(1910>,1)  ♦  RIGHTS(LITH0S,7) 

1077 

1720 

RECOUTS  =RECOUTS  ♦  "912"  ♦  GR0UP2S( 1910, I910.A) 

************************************************** ***************** 


*•••  RECORD  TYPE  «1“  -  RECKEY  PLUS  TYPE  1  FIELDS 


RECOUTS  :><9101««RECKEY$  'TRANSACTION  IDENTIFIER 
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Offset 

1098 

10A0 

10AB 

108F 

10D1 

1001 

1005 

1005 

1005 

1005 

1005 

10E3 

10F6 

10f9 

10F9 

10F9 

IOTA 

10FA 

10FA 

10FA 

10F8 

tOFB 

'102 

1112 

1116 

1116 

1116 

1116 

1117 

1117 

1117 

1117 

1117 

1117 

1117 

1.17 

1117 

1117 

1117 

1117 

1117 

1129 

1’37 

1158 

1166 

1174 

ll’B 

1191 

11A7 

HAS 

I  lAE 
11AE 

II  2 
.1C9 


Data 

Sour< 

1720 

1720 

1720 

1720 

260 

1720 

1720 

GOTO 

1720 

1720 

REM 

1720 

REM 

1720 

REM 

1720 

280 

1722 

1722 

1722 

1722 

1722 

299 

1722 

1722 

REM 

1722 

1722 

998 

1722 

1722 

999 

1722 

1722 

1722 

1722 

REM 

1722 

1722 

1000 

1722 

REM 

1722 

REM 

1722 

REM 

1722 

REM 

1722 

REM 

1722 

REN 

1722 

REM 

1722 

REN 

1722 

REM 

1722 

REM 

1722 

REM 

1722 

REM 

1722 

1001 

1722 

1722 

172E 

172E 

172E 

172E 

172E 

172E 

172E 

172E 

172E 

1002 

172E 

172E 

<==  = 
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GOSU8  280 
PRINT  BI.RECOUTS 
NEXT  I910.A 
NEXT  1910 


SUBROUTINE  280  -  PAD  THE  RECORO  TO  MAXLENGTH 

***e******«********e******************e*************««**********e*< 

PAO^MAXLENGTH  •  LEN(RECOUTS)  'FIND  OUT  HOW  SHORT  THE  RECORO  IS 
RECOUTS  X  RECOUTS  »  STRINGSfPAD.PAOS)  ‘PAD  THE  RECORO  UITH  FILL  CHAR 
RETURN 


•END  OF  MQOULE  RXXM910.M02- 


REAOTYPE  s  2 

IF  LN. COUNT  >  48  THEN  GOSUB  7100 
GOTO  10 


'PRINTER  HEADING 


REM  END  OF  SCAN/OECOOE/URITE  LOOP  x==x==*==»=* 


BCSSXSXBSSSSSSSSSSS 


REM  SINCLUOE:  'RACS1000.SUB'  INCLUOE  THE  VERIFY  LOGON  SUB 


NAME:  RACS1000 


LOGON  VERIFICATION  SUBROUTINE 
PATIENT  REGISTRATION  PROGRAM 

B*************************************** 

PATIENT  OMR  INPUT  PROGRAM 


This  program  verifies  user  is  logged  on  properly.  If  there  is  no 
valid  user  logged  on  at  the  time  of  execution,  this  subroutine  will 
chain  to  the  logon  program  RACP05,  otherwise  a  return  is  issued. 


RESERVED  LINE  NUMBERS  ARE  1001  THRU  1010 

«*******•******•******«**•*•*•••**«•**•*••*• 


■HAKE  THEM  LOG  ON  FIRST 

■MAKE  THEM  LOG  ON  FIRST 

•MAKE  THEM  LOG  ON  FIRST 


IF  EOF(I)  THEN  1002 

INPUT  #1,USER$(1),0T$,TMS,PI0$ 

IF  USERSID  »  THEN  1002 
IF  USERSd)  =  ■■•••••••<  then  1002 

CLOSE  1 

SCREEN  0,1, 0,0 
COLOR  FORE, BACK, BORO 
CLS 
RETURN 


CHAIN  "RACP05" 

r=======END  OF  LOGON  VERIFY  SUBROUTINE  1000==x=»x«==========x== 


I 
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11B9 

172E 

11B9 

172E 

2000 

REM  $ INCLUDE:  ‘ RACS2000 . SUB • 

INCLUDE  THE  REPLY/DELAY  SUB 

11BA 

172E 

REM 

11BA 

172E 

REM 

AMBULATORY  CARE  DATA 

BASE  13  APR  85 

•*** 

11BA 

172E 

REM 

•««* 

SKIP  COLE 

**•* 

11BA 

172E 

REM 

SUBROUTINE  NAME 

RACS20O0.SUB 

*«•* 

11BA 

172E 

REM 

**** 

SCANNER  PROGRAM  « 

ALL 

11BA 

172E 

REM 

•*«* 

FUNCTION 

THIS  SUBROUTINE  MODULE 

11BA 

172E 

REM 

•*** 

SERVERS  AS  A  UAIT  AND  REPLY 

**«* 

11BA 

172E 

REM 

***« 

ENTRY  MODULE 

•*** 

11BA 

172E 

REM 

*«*• 

INPUT 

SINGLE  KEYBOARD  ENTRY 

*•** 

11SA 

172E 

REM 

***• 

11BA 

172E 

REM 

OUTPUT 

KEYBOARD  ENTRY  -  UPPER  CASE 

*•** 

11BA 

172E 

REM 

***« 

11BA 

172E 

REM 

RESERVED  LINE 

***« 

11BA 

172E 

REM 

**«• 

NUMBERS 

2001-2010 

•*** 

11BA 

172E 

REM 

*«*««• 

k«*** 

11BA 

172E 

2001 

REM  REPLY  FUNCTION 

11BB 

172E 

2002 

REPLY$= 

INKEYS  :  IF  REPLY$=""  THEN  2002 

11CF 

1732 

REPLY=ASC(REPLY$) 

1109 

1734 

IF  REPLY  >  90  THEN  REPLY$=CHR$<REPLY  XOR  32)  'CONVERT  TO  CAPS 

11F4 

1734 

IF  REPLYS  <  "A"  OR  REPLYS  >  "Z"  THEN  REPLYSe"?" 

1220 

1734 

RETURN 

1223 

1734 

1223 

1734 

5000 

REM  $ INCLUDE:  'RACS5000.SUB' 

INCLUDE  THE  DATE  EDITOR  SUB 

1224 

1734 

REM 

»***« 

1224 

1734 

REM 

**«* 

AMBULATORY  CARE  DATA 

BASE  13  APR  85 

1224 

1734 

REM 

•  ««« 

SKIP  COLE 

1224 

1734 

REM 

««** 

SUBROUTINE  NAME 

RXXSSOOO.SUB 

*•*« 

1224 

1734 

REM 

SCANNER  PROGRAM  # 

ALL 

1224 

1734 

REM 

***« 

FUNCTION 

THIS  SUBROUTINE  MODULE 

««** 

1224 

1734 

REM 

**«« 

PERFORMS  A  DATE  EDIT 

1224 

1734 

REM 

**** 

1224 

1734 

REM 

*«** 

INPUT 

DATE  TO  BE  CHECKED  MUST  BE 

1224 

1734 

REM 

***« 

IN  THE  VARIABLE  NAMED 

1224 

1734 

REM 

'CK.SOOOS' 

1224 

1734 

REM 

***« 

IN  THE  FORMAT  "YYHMDD" 

•*** 

1224 

1734 

REM 

***• 

**** 

1224 

1734 

REM 

**** 

OUTPUT 

'RT.5000'  IS  THE  RETURN  CWE 

1224 

1734 

REM 

VARIABLE.  IF  THIS  VARIABLE 

1224 

1734 

REM 

*•** 

CONTAINS  ANY  NUMBER  OTHER 

•*** 

1224 

1734 

REM 

THAN  0,  AN  ERROR  WAS  FOUND 

1224 

1734 

REM 

IN  THE  DATE. 

*•** 

1224 

1734 

REM 

**** 

1224 

1734 

REM 

•  *«* 

RESERVED  LINE 

•*** 

1224 

1734 

REM 

NUMBERS 

5001-5009 

««•* 

1224 

1734 

REM 

1224 

1734 

RT 

.5000  =  0 

122B 

1734 

CKYEAR  =  VAL(LEFT$<CK.5000$,2))  'YEAR  NUMERIC  VALUE 

123E 

1736 

CKMONTH  =  VAL(MI0$(CK.5000$,3,2))  'MONTH  NUMERIC  VALUE 

1254 

1738 

CKDAY  =  VAL(RICHT$<CK.5000t,2))  'DAY  NUMERIC  VALUE 

1267 

173A 

1267 

173A 

IF  CKMONTH  <  1  THEN  RT. 5000=1  :  GOTO  5009 

1270 

173A 

IF  CKMONTH  >  12  THEN  RT. 5000=1  :  GOTO  5009 
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1293 

173A 

IF  Cl® AT  <  1  THEN  RT.5000>2  :  GOTO  5009 

12A9 

173 A 

IF  aCDAY  >  31  THEN  RT.5000>2  :  GOTO  5009 

12BF 

173A 

12BF 

173A 

REM 

LEAP  YEAR  CHECK 

128F 

173A 

M0LENGTH(2}  ■  28 

12C6 

173A 

IF  CKHONTHo  2  THEN  GOTO  5005  'MUST  BE  FEBRUARY 

1205 

173A 

IF  (CKYEAR  MOO  4}  0  0  THEN  GOTO  5005  ‘MUST  BE  A  LEAP  YEAR 

12EA 

173A 

HOLENGTH(2)  =  29 

12F1 

173  A 

12F1 

173  A 

5005 

IF  CKDAY  >  MOLENGTH(CKMONTH) 

THEN  RT.5000<3  :  GOTO  5009 

1310 

173  A 

1310 

173A 

5009 

RETURN 

1313 

173A 

1313 

173A 

1313 

173A 

1313 

1314 

1314 

173A 

173A 

173A 

5010 

REM 

REM 

REM  SINCLUOE:  <RACS5010.SU8< 

INCLUDE  THE  NUMERIC  STRING  EDITOR 

••••  AMBULATORY  CARE  DATA 

BASE  1  HAY  85 

1314 

173A 

REM 

SKIP  COLE 

**** 

1314 

173  A 

REM 

SUBROUTINE  NAME 

RXXS5010.SUB 

**•* 

:314 

173A 

REM 

••••  SCANNER  PROGRAM  # 

ALL 

1314 

173A 

REM 

••••  FUNCTION 

THIS  SUBROUTINE  NODULE 

1314 

173A 

REM 

**** 

PERFORMS  A  NUMERIC  STRING 

1314 

173  A 

REM 

«*«• 

EDIT. 

'314 

173A 

REM 

***« 

•«** 

1314 

173A 

REM 

*•**  INPUT  : 

STRING  TO  BE  EDITED  IS  IN 

1314 

173A 

REM 

THE  variable  NAMED 

1314 

173A 

REM 

•CK.5010S' 

1314 

173A 

REM 

««•** 

1314 

173A 

REM 

••••  OUTPUT 

■RT.5010'  IS  THE  RETURN  CODE 

**** 

314 

173A 

REM 

VARIABLE.  IF  THIS  VARIABLE 

**«* 

1314 

173A 

REM 

***« 

CONTAINS  ANY  NUMBER  OTHER 

**•* 

1314 

173A 

REM 

***• 

THAN  0.  AN  ERROR  UAS  FOUND 

1314 

173  A 

REM 

***« 

IN  THE  STRING. 

1314 

173A 

REM 

•*** 

1314 

173  A 

REM 

RESERVED  LINE 

***% 

1314 

173A 

REM 

NUMBERS 

5011-5019 

1314 

173A 

REM 

13'4 

173A 

RT.5010  =  0 

1318 

173A 

*118 

173  A 

FOR  15010  =  1  TO  LEN(CK.5010$) 

1323 

173C 

J5010:  ASC(MI0$(CK.5010S, 

15010,1)) 

133F 

1740 

IF  J5010  <  48  OR  J5010  > 

57  THEN  RT.5010  *  RT.5010  ♦  1 

13o7 

1740 

NEXT  15010 

1378 

1740 

1378 

1378 

1740 

1740 

RETURN 

tNU  Ur  wUdK^U  1 1 Nc 

1373 

1740 

5500 

REM  INCLUDE:  ■RACS5500.SUB' 

INCLUDE  THE  OUTPATIENT  UCA  CHECK 

SUB 

137C 

1740 

137C 

1740 

6000 

REM  SINCLUOE:  ' R ACS6000 . SUB ' 

INCLUDE  THE  INSTRING  DECODE  ROUTINE 

1370 

1740 

REM 

1370 

1740 

REM 

AMBULATORY  CARE  DATA 

BASE  13  APR  85 

**** 

1770 

1740 

REH 

**** 

SKIP  COLE 

**** 

13:  1 

1740 

REM 

****  SUBROUTINE  NAME 

RXXS6000.SUB 

*•** 
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137D 

1740 

REM 

**** 

SCANNER  PROGRAM  M  : 

ALL 

***« 

137D 

1740 

REM 

FUNCTION  : 

THIS  SUBROUTINE  MODULE 

137D 

1740 

REM 

**«* 

PERFORMS  INSTRING  SEARCH 

**«* 

137D 

1740 

REM 

*«** 

*«** 

137D 

1740 

REM 

*«** 

INPUT  : 

STRING  TO  BE  SEARCHED  MUST 

137D 

1740 

REN 

BE  IN  THE  VARIABLE  NAMED  : 

137D 

1740 

REM 

**** 

•X$' 

**** 

1370 

1740 

REN 

•«*« 

1370 

1740 

REM 

OUTPUT  ; 

■TOT'  a  total  number  OF 

*«*« 

1370 

1740 

REM 

HITS  IN  THE  DESTRING 

*««* 

1370 

1740 

REN 

«**« 

■HOLDSO*  IS  THE  ARRAY 

**** 

1370 

1740 

REN 

CONTAINING  THE  NUMERIC 

1370 

1740 

REM 

**«* 

VALUE  OF  THE  HIT  POSITIONS 

1370 

1740 

REM 

«*•* 

1370 

1740 

REM 

*••«•*««*«**«««*««««**«••«•****««««***««*««««**«*••««««****#*•***•• 

1370 

1740 

REM 

***« 

RESERVED  LINE 

1370 

1740 

REM 

«•*« 

NUMBERS  : 

6001-6009 

*«** 

1370 

1740 

REM 

1370 

1740 

6001 

PTR  •  INSTRIXS,"!") 

138B 

1740 

TOT  a  0 

1392 

1740 

WHILE  PTR  >  0 

1390 

1740 

T0T=T0T+1 

13AS 

1740 

HOLOS(TOT)  a  RIGHTS(STR$(PTR),2) 

13C7 

1740 

PTRaPTR+1 

13CF 

1740 

PTR  a  INSTR{PTR,XS,"1" 

) 

13E1 

1740 

WENO 

13E5 

1740 

RETURN 

13E8 

1740 

t3E8 

13E8 

1740 

13E8 

1740 

13E8 

1740 

7000 

REN  SINCLUOE:  'RACS 7000. SUB' 

INCLUDE  THE  SCREEN  HEADER  SUB 

13E9 

1740 

REM 

«««*«•««*♦*«*♦«•*•♦*«***««*•**** 

13E9 

1740 

REM 

«*«• 

AMBULATORY  CARE  DATA  BASE  13  APR  85 

***« 

13E9 

1740 

REM 

•**« 

SKIP  COLE 

13E9 

1740 

REN 

•••* 

SUBROUTINE  NAME 

RACS7000.SU8 

•••• 

13E9 

1740 

REM 

***• 

SCANNER  PROGRAM  *  : 

ALL 

13E9 

1740 

REM 

*««* 

FUNCTION  : 

THIS  SUBROUTINE  MODULE 

*•«* 

13E9 

1740 

REM 

PRINTS  THE  STANDARD  SCREEN 

13E9 

1740 

REM 

**•* 

HEADING. 

13E9 

1740 

REM 

**** 

INPUT  : 

COMMON  VARIABLE  USER$(2) 

**** 

13E9 

1740 

REN 

*•«* 

SYSTEM  DATE 

13E9 

1740 

REN 

•*** 

13E9 

1740 

REM 

OUTPUT  : 

SCREEN  HEADING 

13E9 

1740 

REM 

**«• 

**•« 

13E9 

1740 

REM 

*•«« 

RESERVED  LINE 

***• 

13E9 

1740 

REN 

•  *** 

NUMBERS  : 

7001-7010 

•••* 

13E9 

1740 

REM 

••••«** 

«***♦ 

13E9 

1740 

13E9 

1740 

7001 

LOCATE  1 

,1 

13F3 

1740 

PRINT  "U 

S.  ARMY  AMBULATORY  CARE  INFORMATION  SYSTEM" 

13FB 

1740 

LOCATE  1 

,65 

1408 

1740 

PRINT  DATES; 

1410 

1740 

LOCATE  2 

,1 
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1410 

142A 

1420 

4£^e 

1740 

1740 

1740 

IT/ ft 

7100 

PRINT  "USER  :  ";USERS(1} 
RETURN 

REN  SINCLUDE:  'RACSZIOO.SUB' 

INCLUDE  THE  PRINTER  HEADER  SUB 

|42E 

142E 

1  /4U 

1740 

REN 

REM 

*««« 

AMBUUTORY  CARE  DATA 

BASE  13  APR  85 

*«*• 

142E 

1740 

REM 

**«« 

SKIP  COLE 

142E 

1740 

REM 

SUBROUTINE  NAME 

:  RXXSFIOO.SUB 

**** 

14a 

1740 

REM 

SCANNER  PROGRAM  « 

:  ALL 

**** 

142E 

1740 

REM 

***• 

FUNCTION 

:  THIS  SUBROUTINE  NODULE 

**** 

142E 

1740 

REM 

**** 

PRINTS  THE  STANDARD  HEADING 

**«* 

142E 

1740 

REM 

***« 

ON  THE  PRINTER. 

***« 

142E 

1740 

REN 

•«*« 

INPUT 

:  DATE. PAGE, PGMIDS.PGMTITLS 

**** 

.42E 

1740 

REM 

**** 

**«* 

142E 

1740 

REM 

•*** 

OUTPUT 

:  PRINTER  HEADING,  LN. COUNT 

14Z£ 

1740 

RE« 

- — 

142E 

1740 

REM 

**** 

RESERVED  LINE 

*««« 

142E 

1740 

PEM 

NUMBERS 

:  7101-7110 

**•* 

I42E 

1740 

REM 

**«***«•*«**««**«***«***««*«*•**•****•***«••**•**«******•*•*••***•« 

142E 

1740 

142E 

1740 

7101 

IF  PAGE  >  0  THEM  LPRINT  CHR${12); 

1444 

1740 

LPRINT 

"ARMY  AMBULATORY  CARE 

INFORMATION  SYSTEM _ ".-PGMTITLS; 

1451 

1740 

LPRINT 

TAB<70);0ATES 

1464 

1740 

PAC£=PAO£+1 

146C 

1740 

LPRINT 

"PROGRAM  ";PGHI0$;TAB(70);"PACE"; 

1489 

1740 

LPRINT 

USING  PAGE 

1495 

1740 

LPRINT 

1490 

1740 

LN. COUNT 

=3 

14A4 

1740 

RETURN 

14A7 

1740 

’4A7 

1740 

8000 

REN  SINCLUDE:  'RACS8000.SUB' 

INCLUDE  THE  DECODE  SUB  GROUP 

14A8 

1740 

REM 

«««««**««*#«***«««*«**«*****«**««***«*1H»**««*******«*«*ft«********** 

14A8 

1740 

REM 

AMBULATORY  CARE  DATA 

BASE  13  APR  85 

r.A8 

1740 

REM 

**«« 

SKIP  COLE 

14A8 

1740 

REM 

SUBROUTINE  NAME 

:  RXXS8000.SUB 

**• 

14A8 

1740 

REM 

««•« 

SCANNER  PROGRAM  « 

:  ALL 

**• 

14A8 

1740 

REM 

*«»# 

FUNCTION 

:  THIS  SUBROUTINE  MODULE 

1.'A8 

1740 

REM 

««*« 

IS  A  GROUPING  THAT  PERFORMS 

*«* 

14A8 

1740 

REM 

*««* 

VARIOUS  DECODING  FUNCTIONS 

14A8 

1740 

REM 

**** 

ON  THE  SCANNER  DATA 

*** 

*4A8 

1740 

REM 

•««« 

I4A8 

1740 

REM 

**«* 

8001  -  DECODE  THE 

HEADER  POSITIONS  (POINTER  0-20) 

*** 

14A8 

1740 

REM 

*««« 

8050  -  CHECK  FOR 

END  OF  JOS 

**« 

1/A8 

1740 

REM 

**** 

8100  -  PRINT  THE 

HEADER  DATA  ON  THE  SCREEN 

14A8 

1740 

REN 

*««* 

8200  -  DECODE  THE 

RESPONSE  POSITIONS  (POINTER  21 -. 

)  •** 

14A8 

1740 

REM 

(RETURNED 

IN  TEXTS  STRING  VARIABLE) 

•** 

14a8 

1740 

REM 

**** 

*«* 

14A8 

1740 

REM 

**** 

INPUT 

:  SHEET  RECORD,  RECORD  LENGTH 

14A3 

1740 

REM 

**** 

*** 

1'.A8 

1740 

REM 

OUTPUT 

:  'TEXTS’  TRING  VARIABLE 

14Aa 

1740 

REM 

•*** 

14Af 

1740 

REM 

RESERVED  LINE 

*•* 

•4A8 

1740 

REM 

Numbers 

:  8001-8500 

V  A8 

1740 

REM 

HAS  1740 


■ 

1 

■i 

\ 

\ 

‘i 

t 

h 

IUCP910 

' 

."AGE  17 

i 

OT  REPEAT  VISIT 

FORM 

04-27-87 

r 

09:33:14 

t 

Offset 

Oats 

Source  Line 

IBM  Personal  Coaiputer  BASIC  Coopiler  WOO 
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HAS 

1740 

■OECOOE  THE  HEADER  ONLY 

r 

UA8 

1740 

8001 

POINTER  <•  0 

t 

1 

14AF 

1740 

RECOROPTR  ■  VARPTR(SHEETREC(0)) 

1 

1742 

FOR  J8000  •  1  TO  21 

USD 

1742 

8002 

TEXTS>  TEXTS*CHRS(PEEK(RECORDPTR  *  POINTER)) 

1408 

1742 

POIHTER»POINTER+1 

14E3 

1742 

NEXT  J8000 

14F2 

1744 

PROGRAMS::  LEFTS(TEXTS,3) 

1501 

1748 

BATCH»>  MIDS(TEXTS,4,3) 

j 

1513 

174C 

SERIALS-  MI0S<TEXTS,7,4) 

1 

1525 

1750 

RUNIDS>  M10S(TEXTS,11,1) 

1537 

1754 

FORHS<  MID$<TEXTS,12,2) 

1549 

1758 

POCKETS*  MI0S(TEXrS,14,1) 

• 

1558 

175C 

SCANERR1S*MI0S(TEXTS,16,2) 

1560 

1760 

SCANERR2S*MI0S(TEXTS,18,2) 

157F 

1764 

SCANERR3S*HI0S( TEXTS, 20,2} 

1 

1591 

1768 

GOTO  8500 

1595 

1768 

1595 

1753 

8050 

REM  CHECK  FOR  END  OF  JOB/ENO  OF  BATCH 

1596 

1768 

IF  PROGRAMS  a  PGMIOS  THEN  GOTO  8500 

15A8 

1768 

LPRINT  STRINOStSO,"*") 

1586 

1768 

LPRINT 

H  1 

1586 

1768 

LPRINT  "RECORDS  PROCESSED  ...  «; SERIALS 

15C8 

1768 

LPRINT  “STARTED  AT  .  ";BTIMES 

1508 

1768 

LPRINT  "ENDED  AT  .  ";TIMES 

15E5 

1768 

LPRINT  CHRS(12) 

15F0 

1768 

GOTO  30000 

15F4 

1768 

i 

15F4 

1768 

8070 

REM  CHECK  FOR  SCANNER  ERRORS 

■ 

15F5 

1768 

IF  POCKETS  *  "  "  GOTO  8500 

1607 

1768 

LPRINT  LITHOS; 

160F 

1768 

LPRINT  "  ...  SCANNER  ERRORS  :  "; 

1617 

1768 

LPRINT  SCANERRIS;"  /  "; 

1624 

1768 

LPRINT  SCANERR2$;"  /  "; 

1631 

1768 

LPRINT  SCANERR3S 

1 

1639 

1768 

LN*LN+1 

1641 

176A 

GOTO  999 

1645 

176A 

1645 

176A 

8100 

REM  PRINT  THE  HEADER  VARIABLES  ON  THE  TUBE.... 

1646 

176A 

LOCATE  5,1:PRINT  "PROGRAM  ".-PROGRAMS; 

1660 

176A 

1 

1660 

176A 

PRINT  "  BATCH  ";BATCHS; 

1660 

176A 

PRINT  "  RUN  ";RUNIDS; 

167A 

176A 

PRINT  ■  FORM  ";FORMS; 

1687 

176A 

PRINT  "  POCKET  ".’POCKETS 

1694 

176A 

GOTO  8500 

1698 

176A 

1698 

176A 

8200 

REM  DECODE  THE  RESPONSE  POSITIONS 

■ 

1699 

176A 

POINTER  a  21 

16A0 

176A 

RECOROPTR  a  VARPTR(SHEETREC(0)) 

16A7 

176A 

FOR  J8000  a  22  TO  RECORDLENGTH 

1684 

176C 

8202 

TEXTS  a  TEXT$*CHR$(PEEK(REC0H0PTR  ♦  POINTER)) 

1602 

176C 

POINTERaPOINTER»1 

160A 

176C 

NEXT  J8000 

1 
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16EB  176C 


16EB 

176C 

8500 

RETURN 

16EE 

16EE 

176C 

176C 

16EE 

176C 

IEEE 

176C 

9000 

REM  SINCLUDE:  ■RACS9000.SUB'  INCLUDE  THE  SCANNER  CONTROL  SUB 

16EF 

176C 

REM 

l6£F 

176C 

REM 

***« 

AMBULATORY  CARE  DATA  BASE  13  APR  85 

***« 

16EF 

176C 

REN 

*«** 

SKIP  COLE 

*««• 

16EF 

176C 

REM 

*«** 

PROGRAM  NAME 

:  RACS9000.SUB 

**** 

16EF 

176C 

REM 

SCANNER  PROGRAM  0 

:  ALL 

•*** 

16EF 

176C 

REM 

FUNCTION 

:  THIS  SUBROUTINE  MODULE 

*«*• 

16EF 

176C 

REM 

***« 

CONTROLS  THE  SCANNER  I/O 

***« 

16EF 

176C 

REM 

16EF 

176C 

REN 

*«*« 

INPUT /OUTPUT 

:  REFER  TO  THE  ASYNCHRONOUS 

16EF 

176C 

REM 

COMMUNICATIONS  MANUAL  AND  THE 

*•** 

16EF 

176C 

REM 

**«« 

PRE-RELEASEO  SOFTWARE  GUIDE 

16EF 

1EEF 

1EEF 

176C 

176C 

176C 

REM 

REN 

REN 

•**« 

**** 

#*** 

RESERVED  LINE 

**** 

16EF 

16EF 

176C 

176C 

REN 

NUMBERS 

;  9001-9100 

REM 

wikik  V 

**■**■*■****■**■■•■■*■■■■••*•*••••■• 

16EF 

176C 

16EF 

lEEF 

16EF 

176C 

176C 

176C 

REM 

REM 

*•*« 

SUBROUTINE  9001  -  PROTOCOL  SETUP  FOR  SCANNER 

I6EF 

176C 

REM 

«««« 

ARGUMENTS:  PRESET  ... 

SEE  BELOW 

'6EF 

176C 

REN 

16EF 

t76C 

9001 

REN 

16F0 

176C 

PROTOCOLfO)  «  9600 

•BAUD  RATE 

16F7 

176C 

PROTOCOL<1)  =  78 

•PARITY  (SEE  PAGE  4-8  OF  MANUAL) 

1SFE 

176C 

PROTOCOL(2)  >  8 

•DATA  BITS 

1705 

176C 

PROTOCOL(3)  »  1 

•STOP  BITS 

170C 

176C 

PROTOCOL<4)  =  2 

•RS-232  PORT 

1713 

176C 

PROTOCOL(5)  =  0 

•WRITE  TIME-OUT 

171A 

176C 

PROTOCOL(6)  °  0 

•READ  TIME-OUT 

1721 

176C 

1  21 

176C 

ERRSTATS  °  SPACES(60) 

1720 

176C 

ARCPTR  =  VAHPIR(PROTOCOL(0)) 

1734 

176E 

CALL 

SETUP  (ARGPTR, ERRSTATS) 

1745 

176E 

ERRMSG$="" 

174E 

176E 

IF  ASC(ERRSTATS)  <>  64  THEN  ERRH$GS=»SETUP  ERROR  "^ERRSTATS 

176A 

176E 

GOTO  9100 

76E 

176E 

170E 

176E 

REM 

*«•* 

176' 

176E 

REM 

SUBROUTINE  9010  ■  CONTROL  OPTIONS  FOR  SCANNER 

■.76E 

176E 

REM 

***« 

ARGUMENTS:  CNTRLOPT 

1  6E 

176E 

REM 

***• 

CNTRLOPT  »  1  =■  START 

SCANNER  (SI) 

176E 

176E 

REM 

**** 

CNTRLOPT  =  2  »  STOP 

SCANNER  (SO) 

176E 

176e 

REM 

***« 

CNTRLOPT  3  3  >  TERMINATE  COMMUNICATIONS  TO  SCANNER  (DC3) 

176i 

176E 

REM 

**•* 

CNTRLOPT  3  4  =  CLEAR 

TRANSPORT  PATH  (DC2) 

176E 

176E 

REM 

•*«« 

CNTRLOPT  =  5  3  SELECT 

PRIMARY  STACKER  "31^^ 

i:6E 

176E 

REM 

CNTRLOPT  363  SELECT 

SECONDARY  STACKER  ••32" 

«**** 

176E 

176E 

REM 

CNTRLOPT  3  7  3  POSITIVE  RESPONSE/SELECT  SCANNER  (DC1) 

8  V 
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176E 

176E 

1766 

176E 

176E 

176E 

REM 

REM 

9010 

CMTRLOPT  «  8  «  REQUEST  STATUS  (ESC)  **•*• 

REM 

176F 

176E 

ERRSTATS  >  SPACE$(60) 

177B 

176E 

CALL  CNTROL  (CNTRLOPT, ERRSTATS) 

178C 

176E 

ERRMS(»°'*" 

1795 

176E 

IF  ASC(ERRSTATS)  <>  64  THEM  ERRMSGt3>«CONTROL  ERROR  •^ERRSTATS 

17B1 

176E 

GOTO  9100 

17B5 

1785 

17B5 

176E 

176E 

176E 

REM 

REM 

****  SUBROUTINE  9020  •  SCAN  SHEET  CALL 

17B5 

176E 

REM 

**«« 

17B5 

176E 

REM 

ARGUMENTS;  REAOTYPE 

***** 

17B5 

176E 

REM 

*•••  REAOTYPE  «  2  >  REQUEST  NEW  DOCUMENT  FROM  SCANNER 

***** 

17B5 

176E 

REM 

REAOTYPE  »  3  «  RETRANSMIT  CURRENT  DOCUMENT 

17B5 

t76£ 

REM 

***** 

17BS 

176E 

REM 

****  ARGUMENTS:  RECOROLENGTH 

***** 

17B5 

176E 

REM 

•***  NUMERIC  VARIABLE  SET  TO  THE  NUMBER  OF  CHMUCTERS  TO  BE 

***** 

1785 

176E 

REM 

TRANSMITTED 

***** 

17B5 

176E 

REM 

17B5 

176E 

9020 

REM 

1786 

176E 

ERRSTATS  >  $PACES(60) 

17C2 

176E 

RECOROPTR  >  VARPTR(SHEETREC(0)) 

17C9 

176E 

CALL  SCAN  (REAOTYPE, RECOROLENGTH, RECOROPTR.ERRSTATS) 

17E2 

176E 

ERRHSG$="" 

17E8 

176E 

IF  MIDS(ERRSTATS,14,3)  *  "415"  THEN  ERRMSGS»"ESC" 

180C 

176E 

GOTO  9100 

1810 

176E 

1810 

176E 

REM 

1810 

176E 

REM 

SUBROUTINE  9030  -  TRANSPORT  PRINT  CALL 

***** 

1810 

176E 

REM 

***** 

1810 

176E 

REM 

••••  ARGUMENTS:  PRINTPOS 

***** 

1810 

176E 

REM 

••••  NUMERIC  VARIABLE  INDICATING  THE  STARTING  PRINT  POSITION 

***** 

1810 

176E 

REM 

••••  VALUES  =  0  THRU  90 

1810 

176E 

REM 

«*«« 

1810 

176E 

REM 

••••  ARGUMENTS:  PSTRIHGS 

***** 

1810 

176E 

REM 

••••  TEXT  TO  BE  PRINTED  ON  THE  FORM 

***** 

1810 

176E 

REN 

***• 

1810 

176E 

REM 

••••  NOTE:  THIS  ROUTINE  HAS  NO  EFFECT  IHILESS  THE  SCAN 

1810 

176E 

REM 

HEADER  SHEET  IS  MARKED  'PRINTER  ON' 

***** 

1810 

176E 

REM 

1810 

176E 

9030 

REM 

1811 

176E 

ERRSTATS  -  SPACES(6Q) 

181D 

176E 

RECOROPTR  <  VARPTR(SHEETREC(0)) 

1824 

176E 

CALL  TPR I  NT  (PR I NTPOS ,  PSTR I NGS, ERRSTATS) 

1839 

1774 

IF  ASC(ERRSTATS)  <>  64  THEH  ERRHSG$="PRINT  ERROR  "♦ERRSTATS 

1855 

1774 

GOTO  9100 

1859 

1774 

1859 

1774 

9100 

RETURN 

185C 

1774 

Kbn 

165C 

1774 

185C 

1774 

185C 

1774 

25000 

REN  USER  TERMINATED  INPUT...  FILE  IS  NOT  TO  BE  USED!! Ill 

PACE  20 
04-28-87 
09:33:34 

IBM  Personal  Conputer  BASIC  Coopiler  V1.00 


1850 

1774 

LPRINT  "USER  TERMINATED  INPUT  ..  DATA  UILL  MOT  BE  USEDI" 

1865 

1774 

LPRINT  "ERASING  FILE  ".‘OATFILS 

1872 

1774 

BEEP 

1876 

1774 

CLS  :  PRINT  "USER  TERMINDATED  INPUT 

..  DATA  WILL  NOT  BE  USEOI" 

1882 

1774 

CLOSE 

1886 

1774 

OPEN  DATFILS  FOR  OUTPUT  AS  «1 

1898 

1774 

PRINT  •1,STRINGS(REC0R0LENGTH,"X") 

•VOID  THE  FIRST  RECORD 

18AA 

1774 

CLOSE 

18AE 

1774 

18AE 

1774 

30000  REM 

18AF 

1774 

CLOSE 

1863 

1774 

CHAIN  "RACP10" 

188A 

1774 

END 

188E 

1774 

laci 

1774 

22151 

Bytes  Available 

15807  Bytes  Free 


RACP910 

OT  REPEAT  VISIT  FORM 
Offset  Data  Source  Line 


0  Uarning  Error(s) 
0  Severe  Error(s) 


Offset  Data  Source  Line 


PACE  1 
0'-28-87 
09:2b:’3 

IBM  Personal  Coaster  BASIC  Coinpiter  Vi. 00 


001A 

0002 

REH  SLINESIZE:  132 

001A 

0002 

REM  SPACES  I ZE:  66 

001A 

0002 

REM  STITLE:  •RACP920  • 

001A 

0002 

REH  SSUBTITLE:  'PT  REPEAT  VISIT  FORM 

001A 

0002 

REH  SPACE 

i 


RACP920 

PT  REPEAT  VISIT  FOt»l 


t 


Offset 

Data 

001A 

0002 

001A 

0002 

001A 

0002 

ODIA 

0002 

001 A 

0002 

001A 

0002 

001A 

0002 

001A 

0002 

001A 

0002 

001A 

0002 

001A 

0002 

001A 

0002 

001A 

0002 

001A 

0002 

001A 

0002 

001A 

0002 

001A 

0002 

001A 

0002 

001A 

0002 

OOU 

0002 

001A 

0002 

001A 

0002 

001A 

0002 

001A 

0002 

001A 

0002 

J01A 

0002 

001A 

0002 

001A 

0002 

001A 

0002 

roiA 

0002 

ODIA 

0002 

001A 

0002 

0C1A 

0002 

001A 

0002 

001A 

0002 

C31A 

0002 

ODIA 

0002 

001A 

0002 

001A 

0002 

001A 

0002 

ODIA 

0002 

)01A 

0002 

00  iA 

0002 

oon 

0002 

001A 

0002 

C’lA 

0002 

001A 

0002 

001A 

0002 

001A 

0002 

001A 

0002 

OJU 

0002 

001A 

0002 

OOIA 

0002 

001A 

0002 

PAGE  2 
04-28-87 
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Source  Line  IBM  Personal  Computer  BASIC  Compiler  VI. 00 

REM  . . . 

REM  I  NAME:  RACP910  AMBUUTORT  CARE  INFORMATION  SYSTEM  | 

REM  I  DATE:  13  MAR  87  PT  (DHOA)  REPEAT  VISIT  j 

REM  I  0  R  BOLLING  SHORT  FORM  j 

REM  I  I 

REM  I  INCLUDES  PREFIX  TO  LITHO  FOR  EACH  PATIENT  ON  FORM  | 

REM  . . . 

REM  PT  REPEAT  FORM  INPUT  PROOtAM 

REM 

REM  This  program  reads  the  SHORT  form  OMR  data,  converts  various 
REM  fields,  prints  an  error  report  and  produces  the  file: 

REM 

REM  VISIT.DAT 

REM 

REM  for  input  to  FOCUS.  NOTE  THAT  THIS  FILE  IS  OPENED  FOR  APPEND 
REM  each  time  the  program  is  run.  Thus,  if  the  file  does  not  exist, 

REM  records  will  be  added  to  the  front.  If  the  file  exists,  records 
REM  will  be  added  to  the  end  of  the  current  file.  It  is  intended  that 
REM  the  FOCUS  DIALOGUE  MANAGER  ROUTINE  which  loads  the  data  will  delete 
REM  the  data  file  after  the  load  has  been  successfully  accomplished. 

REM 

REM 

REM  If  there  is  no  valid  user  logged  at  the  time  of  execution,  this 
REM  program  will  chain  to  the  logon  program  RXXP05,  otherwise, 

REM  THE  PROGRAM  CHAINS  TO  PROGRAM  RACP10  ON  EXIT. 

REM  SINCLUOE:  'RACOIM.MOO'  REM  INCLUDE  THE  DIMENSION  DEFINU IONS 

I********************************************************************** 

'•  NAME:  RACOIM.MOO  DIMENSION  DEFINITIONS  * 

'*  Date:  28  Feb  84  Written  by:  Floyd  Cole  • 

■  *********««*«*««•*«****«•*«•****•**•*  *******l^*«***tk***«*********«***** 

'  Dimensioned  variables  are  defined  in  this  file. 

'  It  is  an  included  file  so  it  cannot  be  run  in  a  stand-alone, 

'  mode. 

I 

'  This  program  segment  may  be  modified,  but  all  files  containing 
'  an  include  for  this  segment  must  be  re-cumpiled  in  order  to 
'  affect  the  changes  made  here. 

I  •**•••**••••  START  OF  DIMENSION  DEFINITION  •••••*•*••••••*••*•*• 


DEFINT  A-Z 

DIM  USERS(2>,MOLENGTH(12),OATEERR$(3) 
************  ENp  OF  DIMENSION  DEFINITIONS 


REM  DIMENSION  STATEMENTS  UNIQUE  TO  THIS  PROGRAM. 


DIM  SHEETRECdTSO) 
DIM  PROTOCOL(7) 

DIM  EO.HS0S(30) 

DIM  CLINIC2.PFX$(6) 
DIM  PROCED$<26) 


'(MAX.  SIZE  FOR  A  SHEET  FROM  THE  SCANNER) 
'(ARRAY  FOR  SERIAL  BOARD  SETUP  PARAMETERS) 
■(ERROR  MESSAGES  FROM  EDIT  ROUTINES) 
'(PREFIX  -A  B  C  0  F  S-  FOR  CLINIC  #2) 
•(PROCEDURE  TABLE  FOR  SHORT  FORM) 


DIM  PROVIDER. TIH£S(8)  '{PROVIDER  TIME  TABLE) 


RACP920  PA-SE  3 

PT  REPEAT  VISIT  FORM  04-2a-87 
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001A 

0002 

DIM 

REFCOOSdE) 

001A 

0002 

DIM 

VDATS(4) 

001A 

0002 

DIM 

PR1.CC0S(4) 

001A 

0002 

DIM 

PR1.TIMS(4) 

001A 

0002 

DIM 

PR2.C(»S(4) 

001A 

0002 

DIM 

PR2.TIMS(4) 

001A 

0002 

DIM 

SPROV.REAS(4) 

001A 

0002 

DIM 

VIS.CNTS(4) 

001A 

0002 

DIM 

TOT.PROC1(4) 

001A 

0002 

DIM 

TOT.PROC2(4) 

001A 

0002 

DIM 

GRauP1S(6,27) 

001A 

0002 

DIM 

GROUP2S(6,26) 

001A 

0002 

DIM 

HOLDS(26) 

001A  0002 

001A  0002 

001A  0002 

001A  0002 

001A  0002 

001A  0002 

001A  0002 

001A  0002 

001A  0002 

001A 
001A 
001A 
001A 
001A 
001A 
001A 
001A 
001A 
001A 
001A 
001A 
001A 
001A 
001A 
001A 
OOU 
001A 
001A 
0Q1A 
001A 
001A 
001A 
001A 
001A 
001A 
001A 
001A 
001A 
001A 
001A 
001A 


(REFERRAL  COOE  TABLE) 


ARRAYS  TO  HOLD  MULTIPLE  VISITS 


(PATIENT/PROCEDURE  GROUP  PROV  1) 
(PATIENT/PROCEOURE  GROUP  PROV  2) 
(HOLD  AREA  FOR  SUBROUTINE  6000) 


REM  SINCLUOE:  •RACCHN.MOD' 

NAME:  RACCMN.MOO 
Date:  28  Feb  84 


0002 

0002 

0002 

0002 

0002 

0002 

0002 

0002 

0002 

0002 

0002 

0002 

0002 

0002 

0002 

0002 

0002 

0002 

0002 

0002 

0002 

0002 

0002 

0002 

0002 

0002 

0002 

0002 

0002 

0002 

0002 

0002 


REM  INCLUDE  THE  COMMON  AREA  DEFINITION 

»»#*»»*»#*«»»»*»***»**** 

COMMON  AREA  DEFINITION 
Written  ty:  Floyd  Cole 


COMMON  AREA  DEFINITIONS  WILL  BE  HELD  IN  THIS  FILE.  IT  IS  AN 
INCLUDED  FILE  SO  IT  CANNOT  BE  RUN  IN  A  STAN0*AL0NE,  MODE. 

This  program  segment  any  be  aaxlificd,  but  all  files  containing 
an  include  for  this  segment  asist  be  re*campiled  in  order  to 
affect  the  changes  made  here. 


•START  OF  COMMON 


COMMON  FORE, BACK, BOARD, HIDE, EFORE.EBACK, BELLS  'BASIC  SCREEN  COLORS 


COMMON  HEADERS 
COMMON  TEXTS 
COMMON  PGHIOS 
COMMON  MOLENGTHO 
COMMON  USERSO 
*.«**«*******end 


•21  CHARACTER  SCANNER  HEADER  INFO 
"  AIMING  CHARACTERS  FROM  SCANNER 
'PROGRAM  OR  FORM  ID 
■DAYS  IN  THE  MONTH 


OF  COMMON  DEFINITION* 


REM  SINCLUOE:  'RACOEF.MOO' 


REM  INCLUDE  THE  DEFAULT  DEFINITIONS 


NAME:  RACP01.DEF 
Date:  28  Feb  84 


DEFAULT  DEFINITIONS 
Written  by:  Floyd  Cole 


Variables  used  in  conmon  that  have  a  default  value  on  start*up 
will  be  held  in  this  file.  It  is  an  included  file  so  it  cannot 
be  run  in  a  stand*alone  mode.  In  normal  operation,  this  file 
should  be  'included'  in  the  main  program  only  (RACPIO.BAS). 

This  program  segment  may  be  modified,  but  all  files  containing 
an  include  for  this  segnmnt  must  be  re'compiled  in  order  to 
affect  the  changes  made  here. 


FORE  =  15 


•START  OF  DEFAULT  DEFINITION********* 
'FOREGROUND  COLOR  ^  INTENSE  WHITE 


RACP920 
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0050 

1654 

BACK  >  1 

'Background  Color  «  Light  Blue 

0057 

1654 

BORO  ■  4 

■BORDER  <  RED 

005E 

1656 

HIDE  >  4 

■ALTERNATE  COLOR  «  RED 

0065 

1656 

EFORE°  14 

■ERROR  FOREGROUND  DtSPUY 

006C 

1656 

EBACKs  0 

■ERROR  BACKGROUND  DtSPUY 

0073 

1656 

BELLS  *  CHRS(7) 

■Sound  the  bell 

007F 

1656 

007F 

1656 

HOLENGTH(I) 

s 

31  ■JAN 

0086 

1656 

MOLEHGTH(2) 

m 

28  'FEB  <—MOOIFIEO  IN  SUBROUTINE  RACS5000.SUB 

0080 

1656 

HOLENGTH(3) 

s 

31  ‘MAR 

0094 

1656 

HOLENGTH(4) 

a 

30  'APR 

0098 

1656 

MOLEHGTH<5) 

a 

31  ■MAY 

00A2 

1656 

MOLENGTH(6) 

a 

30  ■JUN 

00A9 

1656 

HOLENGTH(7) 

a 

31  ■JUL 

0080 

1656 

HOLENGTH(8) 

a 

31  <AUG 

0087 

1656 

HOLENGTH(9) 

a 

30  ■SEP 

008E 

1656 

HOLEHGTH<10) 

a 

31  ■OCT 

OOC5 

1656 

MOLENGTH(II) 

a 

30  'NOV 

OOCC 

1656 

HOLENGTH(12) 

a 

31  ■DEC 

0003 

1656 

0003 

1656 

0ATEERR$(0) 

a 

M  N 

OODC 

1656 

DATEERRS(I) 

a 

"INVALID  MONTH" 

OOE5 

1656 

DATEERR$(2) 

a 

“INVALID  DAY  " 

OOEE 

1656 

DATEERR$(3) 

a 

“DAY  TOO  LARGE  FOR  MONTH  COOED" 

00F7 

1656 

00F7 

1656 

HAXLENGTH 

a 

80  'MAXIMUM  LENGTH  OF  OUTPUT  RECORD 

OOFE 

1658 

PADS 

a  ' 

'PAD  CHARACTER  FOR  SHORT  RECORDS 

0107 

165C 

0107 

165c 

0107 

165C 

0107 

165C 

0107 

165C 

KEY  OFF 

0100 

165C 

010D 

165C 

REM  •••••*•••••< 

r«*«' 

0100 

165C 

REM  THE  FOLLOWING  VARIABLES  ARE  UNIQUE  TO  EACH  PROGRAM  AND  MUST 

C10O 

165C 

REM  BE  CHANGED. 

0100 

165C 

REM  •••**•••••*« 

»•«« 

01 OD 

165C 

PGMTITLS 

■  "PT  (OHOA)  REPEAT  FORM" 

0116 

1660 

0116 

1660 

PGMIDS  3 

"920"  'VALUE  RECEIVED  FROM  THE  SCANNER 

011F 

1660 

■IN  HEADER  VARIABLE  'PROGRAMS' 

011F 

1660 

011F 

1660 

OATFILS  = 

=  "VI SIT. OAT"  'FILE  TO  BE  INPUT  TO  FOCUS 

0128 

1664 

0128 

1664 

REM  LENGTH  OF  STRING 

RECEIVED  FROM  THE  OMR.... 

0128 

1664 

HEADER  s 

21 

012F 

1666 

RESPONSE’ 

331 

0136 

1668 

RECORDLENCTH 

=  HEADER  ♦  RESPONSE 

0141 

166A 

0141 

166A 

N.PROC  > 

■  26 

'  NUMBER  OF  PROCEDURES  FOR  THIS  FORM 

0148 

166C 

0148 

166C 

REM  *•**••••*•« 

r**«i 

0148 

166C 

0148 

166C 

BTIMEt’TIHES 

'SCAN  START  TIME 

RACP920  PAGE  S 
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0151 

1670 

0151 

1670 

0151 

1670 

REM 

ENCOUMTER 

FORM  CLlNtC  PREFIX  TABLE 

*** 

0151 

1670 

REM 

CLINIC  #2 

0151 

1670 

CLINIC2.PFX$(0): 

N  N 

01 5A 

1670 

CLINIC2.PFXS(1): 

"A" 

0163 

1670 

CLINIC2.PFXS(2} 

(IgW 

016C 

1670 

CLINIC2.PFXS(3} 

IIQII 

0175 

1670 

CL1NIC2.PFXS(4) 

flQH 

01 7E 

1670 

CLINIC2.PFXS(S) 

lipil 

0187 

1670 

CLINIC2.PFX$<6) 

11311 

0190 

1670 

0190 

1670 

REM 

PREASSIGMED  REFERRAL  COOES  ••• 

0190 

1670 

REFCOOS(1)=''AAAA“  :  REFCQO$(07)="BEAA“ 

:  REFCQ0$d3)-"BHAF" 

01AB 

1670 

REFCOOS(2)="AEAA"  :  REFCQO$(08)>"BEDA‘' 

:  REFCQDSd4)>c"BHAG" 

01C6 

1670 

REFC00$(3)=”BAAA"  :  REFCO0$<09)«“BEFA" 

:  REFCODSd5)>"BHAH* 

01E1 

1670 

REFC00S(4)="BAKA"  :  REFC001(10)=«BGYA“ 

:  REFC00$d6)»"BHAl" 

01 FC 

1670 

REFCOO$(S)<"BBAA''  :  REFCQO$(11)°»SHAA'‘ 

:  REFC00Sd7)«“BIYA* 

0217 

1670 

REFCn$(6)-‘‘BBCA"  :  REFCaOS<12)=''BHAE'< 

:  REFCQ0Sd8)>“DHCA* 

0232 

1670 

0232 

1670 

REM 

•••  ENCOUNTER 

FORM  PROCEDURE  TABLE 

<t** 

0232 

1670 

PROCE0${0)*''  " 

PROCEDSdO)  «  *06027“ 

PR0CEDS<20)=  *04014" 

0240 

1670 

PROCE0$(1)="06030” 

PROCEDSdl)  »  "06013" 

PR0CEDS<21)«  "06017" 

0268 

1670 

PROCED$(2)*''97118" 

PROCED$d2)  *  "06014" 

PROCEOS{22>=  "06023" 

0283 

1670 

PROCED$(3)«“97114“ 

PROCEO$d3)  «  "04021“ 

PROCEOS(23}>  *97012" 

029E 

1670 

PR0CE0$(4)="97116" 

PROCED$d4)  »  "06034“ 

PR0CE0S(24)>  "97128" 

02B9 

1670 

PROCED$(5)*"06005« 

PROCED$d5)  =  "06035" 

PROCEDS(25)»  "97022" 

02D4 

1670 

PROCE0S(6)="97010“ 

PROCED$d6)  *  "06063" 

PROCEDS<26)<  "12008" 

02EF 

1670 

PROCE0$<7)="06011“ 

PROCEDSd7)  •  "04011" 

0301 

1670 

PROCED$(8)=''06083'’ 

PR0CED$d8)  »  "04020" 

0313 

1670 

PROCE0$(9)="06028" 

PR0CE0$d9)  =  "97024" 

0325 

1670 

0325 

1670 

REM 

PROVIDER  TIME  TABLE  *•* 

0325 

1670 

PROVIDER. TIME5<00)*"000"  •  NO  TIME 

032E 

1670 

PROVIDER. TIME$<01)="005"  '  5  MINUTES 

0337 

1670 

PROVIDER. TIME$(02)="010"  '10  MINUTES 

0340 

1670 

PROVIDER. TIME$<03)="015"  >15  MINUTES 

0349 

1670 

PROVIDER. TIME$<04)="020"  '20  MINUTES 

0352 

1670 

PROVIDER. TIME$(05)="030"  '30  MINUTES 

035B 

1670 

PROVIDER. TIME$(06)="045"  '45  MINUTES 

0364 

1670 

PROVIDER. TIME$(07)="060"  '60  MINUTES 

0360 

1670 

PROVIDER. TIME$(08)*"999“  •  >  1  HOUR 

0376 

1670 

0376 

1670 

REM 

INCLUDE:  'UCABAMC.OPT'  INCLUDE  OUTPATIENT  UCA  TABLE 

0376 

1670 

0376 

1670 

REM  SPACE 

RACP920 
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0376 

1670 

037B 

1670 

037F 

1670 

0384 

1670 

0384 

1670 

0384 

1670 

0384 

1670 

0384 

1670 

0384 

1670 

0396 

1670 

0396 

1670 

0396 

1670 

0396 

1670 

0396 

1670 

03A1 

1670 

03AB 

1670 

0387 

1672 

03BE 

1672 

0303 

1672 

13E9 

1672 

03E9 

1672 

03E9 

1672 

03E9 

1672 

03E9 

1672 

03E9 

1672 

03EE 

1672 

0408 

1676 

0408 

1676 

0408 

1676 

0414 

1678 

r-42E 

1678 

042E 

1678 

0443 

1678 

044A 

167A 

044A 

167A 

044A 

167A 

044A 

167A 

044A 

167A 

044A 

167A 

044A 

167A 

044B 

167A 

04..B 

167A 

0454 

167E 

046A 

167E 

046A 

167E 

046F 

167E 

048B 

1682 

048B 

1682 

0494 

1682 

0>.99 

1682 

049E 

1682 

04A3 

1682 

0485 

1686 

04BA 

1686 

GOSUB  1000  'MAKE  SURE  THEY  ARE  LOGGED  ON 

CLS 

GOSUB  7000  'PRINT  SCREEN  HEADING 


REN  **•*  OPEN  FILE  TO  CONTAIN  SCANNED  DATA  •*•• 

****************************************************************** 

REM 

OPEN  DAT FILS  FOR  APPENO  AS  *1 


****************************************************************** 

REM  *•**  CLEAR  AND  DISPLAY  PROGRAM  SCREEN  *•*• 

****************************************************************** 

LPRINT  CHRS<1S); 

WIDTH  ••LPT1:",160 

PAGE  >  0  :  GOSUB  7100  'LINE  PRINTER  HEADING 
COLOR  14 

LOCATE  11,26  !  PRINT  “PT  REPEAT  FORM  “ 

COLOR  FORE,BACK,BORD 

pg^  ******************************************************************* 

REM  ••••  COMMUNICATIONS  SETUP  •••• 

REM 

REM  PROTOCOL 
GOSUB  9001 

IF  ERRMSGS  >  “  “  THEN  LPRINT  ERRMSGS  :  GOTO  30000 


REM  START  SCANNER  (SI) 

CNTRLOPT  =1  :GOSUB  9010 

IF  ERRMSGS  >  "  “  THEN  LPRINT  ERRMSGS  :  GOTO  30000 


LOCATE  22,25:PRIMT  "PRESS  'ESC  TO  TERMINATE  SCANNING  " 
REA0TYPE=3  'FIRST  TIME  IN..  SCANNER  IS  STARTED.. 


REM 

REM 

REM 

REM 


•*** 


SET  SCAN  SHEET  CALL 

r*****«**************i 


**** 


10  REM  -  RETURN  POINT  TO  READ  NEXT  SHEET 


AS= INKEYS 

IF  AS=CHRS(27)  THEN  GOTO  25000 

GOSUB  9020  'SCAN  SUBROUTINE  -  GET  A  RECORD 

IF  MI0S(ERRSTATS,14,3)="415"  THEN  GOTO  25000 

. . CLEAR  THE  INPUT  AREA 

GOSUB  8000  'DECODE  HEADER 

GOSUB  8050  'CHECK  FOR  END  OF  JOB/ENO  OF  BATCH 
COSUB  8200  'DECODE  THE  RESPONSE  POSITIONS 
LITHOS  .  MIDS(TEXTt,22,8) 

COSUB  8070  'CHECK  FOR  SCANNER  ERRORS 

GOSUB  8100  'PRINT  THE  DATA  ON  THE  SCREEN 
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04BF 

1686 

04BF 

1686 

REM  SINCLUDE:  •RACM920.MO1 ■  INCLUDE  THE  SHORT  FORM  REFORHAT/EDIT  HOD 

04BF 

1686 

REM 

04BF 

1686 

REM 

*•••  AMBULATORY  CARE  INFORMATION  SYSTEM  13  MAR  87 

»*«* 

04BF 

1686 

REH 

0  R  BOLLING 

•*** 

04BF 

1686 

REM 

•**•  MODULE  NAME  :  RACM920.MO1 

**** 

04BF 

1686 

REM 

*•••  SCANNER  PROGRAM  #  :  920-  PT  REPEAT  VISIT  FORM 

**** 

048F 

1686 

REM 

*#*« 

**** 

04BF 

1686 

PEM 

*•••  PURPOSE  ;  REFORMAT/EOIT  THE  ENCOUNTER 

**** 

04BF 

1686 

REM 

SHORT  FORM  OMR  RECORD. 

**«* 

04BF 

1686 

REM 

046F 

1686 

REM 

RESERVED  LINE  NUMBERS  100-199 

048F 

1686 

REM 

04BF 

1686 

04BF 

1686 

N.ERR  =0  'COUNTS  THE  NUMBER  OF  ERRMS 

04C6 

1688 

04C6 

1688 

REH 

LITHO  CODE  DONE  IN  BAS  PROGRAM  •** 

04C6 

1688 

04C6 

1688 

REH 

•••  CLINIC  ID  •** 

04C6 

1688 

100 

CLl.COD$="OHDA»  'DEFAULT  CLINIC  CODE 

04CF 

168C 

04CF 

168C 

REM 

SSN  AND  FMP  •** 

04CF 

168C 

102 

SSNS=MI0$<TEXT$,3O,9) 

04E1 

1690 

FMEMP$=MI0$<TEXT$,39,2) 

04  F3 

1694 

04F3 

1694 

REM 

•**  REFERRAL  CODE  ••• 

04F3 

1694 

104 

XS=MID$(TEXTS,41,2)  'SINGLE  BUBBLE  CODE 

0505 

1698 

IF  X$=‘'  "  THEM  106 

0513 

1698 

X=VAL(X$) 

0520 

169A 

REF.COO$=REFCOO$<X)  'USE  TABLE 

0532 

169E 

GOTO  108 

0536 

169E 

0536 

169E 

106 

X=VAL(HI0$<TEXT$,43,1)) 

054C 

169E 

REF.C00$=CLINIC2.PFX$(X)  +  MID$(TEXT$,44,3) 

056E 

169E 

056E 

169E 

REM 

•••  UNLISTED  OX  *•* 

056E 

169E 

108 

X=VAL(MID$(TEXT$,47,1)) 

0584 

169E 

IF  X=0  THEN  PRimXS="" 

0598 

16A2 

IF  X=1  THEN  PRIMOX$="V" 

05AC 

t6A2 

IF  X=2  THEN  PRIMOX$="S" 

05C0 

16A2 

XS=MI0$(TEXT$,48,5) 

0502 

16A2 

IF  X$="  "  THEN  112 

05E0 

16A2 

05E0 

16A2 

REM  ...  REMOVE  LEADING  BLANKS  ... 

05E0 

16A2 

110 

IF  LEFT$(X$,1)="  "  THEM  X$=RIGHT$(X$,4)+"  ":GOTO  110 

060F 

16A2 

060  F 

16A2 

112 

LASTCt=RIGHT$(X$,1)  'GET  LAST  CHAR 

061E 

16A6 

IF  LASTCSo"  "  AND  LASTCt<>"0"  THEN  . . REMOVE  V  OR 

S 

064A 

16A6 

PRIH0X$=LEFTS(PRIMDX$+X$,5)  'GET  5  CHAR  ONLY 

065C 

16A6 

065C 

16A6 

IF  PRIM0X$^>"  "  THEN  113 

066A 

16A6 

N.ERR=M.ERRt1 

0672 

16A6 

ED.HSG$(N.ERR)="NO  DIAGNOSIS  COOED" 

0686 

16A6 
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0686 

16A6 

113  REM 

0687 

16A6 

DAT.OFFSET 

X 

53 

068E 

16A8 

PFX.OFFSET 

s 

57 

0695 

16AA 

PR1 .OFFSET 

a 

58 

069C 

16AC 

PRT.OFFSET 

a 

62 

06A3 

16AE 

P2X. OFFSET 

a 

63 

06AA 

16S0 

PR2.0FFSET 

a 

64 

0681 

16S2 

P2T. OFFSET 

a 

68 

06B8 

16B4 

REA.OFFSET 

a 

69 

)6BF 

16B6 

VCT. OFFSET 

a 

70 

06C6 

16S8 

UPR. OFFSET 

* 

71 

06C0 

16BA 

PRC. OFFSET 

a 

76 

0604 

16SC 

PC2. OFFSET 

a 

102 

060B 

166E 

TOT. OFFSET 

s 

75 

06E2 

16C0 

POINTER 

a 

0 

06E9 
06E9 
06FB 
0702 
0716 
0725 
0725 
j725 
072C 
072C 
072C 
0T3E 
0755 
0763 
0778 
0798 
07A6 
07A6 
O’AF 
07B4 
0780 
07C2 
07E6 
07EE 
0814 
0814 
0828 
0828 
0828 
083  F 
0856 
OOjF 
086F 
086f 
0884 
08A7 
08A7 
08A7 
CBBE 
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1 


M 

1 


J 

1 


I 

I 


16C2 

16C2 

16C6 

16C6 

16C8 

16C8 

16C8 

16C8 

16C8 

16C8 

16C8 

16CC 

16CC 

16CC 

16CC 

16CC 

1600 

1600 

1604 

1604 

1608 

1608 

160C 

160C 

160C 

160C 

160C 

160C 

160C 

16E0 

16E4 

16E4 

16E4 

16E4 

16E4 

16E4 

16E4 

16E4 

16E3 


CMS=MIOS(OATES,1.2) 
FOR  1910  =>  1  TO  4 
VDAT$(I910)="  “ 

NEXT  1910 


■CURRENT  month 
■INITIALIZE  DATE  ARRAY 


REM  *•*  REPEAT  THE  FOLLOWING  CODE  4  TIMES 
FOR  1910=  1  TO  4 


J 


REM 


•CURRENT  TEAR 
■MONTH  AND  OAT  FROM  FORM 
•TIME  TO  QUIT 
•OK,  USE  THIS  YEAR 
•USE  UST  YEAR 


116 


***  VISIT  DATE 
YR$=MI0*(0ATE$,9,2) 
X$=MlOS(TEXTi.OAT.OFFSETtPOINrER,4) 

IF  %S="  ■■  THEN  199 

IF  LEFT»<X$,2)<=CM$  THEN  116 
YRS=RIGHTS(STR$(VAL(YR$)-1),2) 

VDATES  »  TRS  ♦  X$ 

EOIT  VISIT  DATE 

CK.5000S=VDAr£$ 

GOSUB  5000  ■DATE  CHECK 

CK.5010SsVOATES 

GOSUB  5010  ■NUMERIC  STRING  CHECK 

IF  RT.5000  »  0  AND  RT.5010  =  0  THEN  GOTO  118 
M.ERR=N.ERR+1 

ED.MSC$<N.ERR)='^TOOAYS  DATE  ■■  ♦  DATEERRS(RT.5000) 


1 

F 


J 

I 


118  VDATt(l910)=VOATE$ 


REM 

120 


•**  PROVIDER  1  ID  (PREFIX  ♦  NUM)  ••• 
PROVI.PFXS  =  MIO$<TEXT$,PFX.OFFSET+POINTER,1) 
PROVI.NUMS  =  MIOS(T£XT$,PR1.0FFSET+POIMTER,4) 
PR1.COOS(I910)=PROV1.PFXS  ♦  PROVI.NUMS 


REM 

122 


*•»  PRIMARY  PROVIDER  TIME  *** 

X=VAL(MIDl(TEXTS,PRT.OFFSET*POIMrER,1)) 

PR1.TIMS(I910)=PROVIDER.TIMES(X) 


REM 

123 


•**  PROVIDER  2  ID  (PFX  +  NUM)  *** 

PROVZ.PFXS  =  MIDS(T£XTS,P2X.0FFSET*P0INTER,1) 
PROV2.NUMS  =  MIDt(TEXT$,PR2.0FFSET»POINTER,4) 


RACP920 
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08OS  16EC  PR2.COOS(I910)=PROV2.PFXS  +  PROV2.NUMS 

08EE  16EC  IF  PR2.COO$(I910)»"  »  THEN  PB»1  ELSE  P8=0  •PROV2  BLANK  INDICATOR 

0917  16EE  IX*=STRS(I910) 

0924  16F2  IF  PROV2.PFX$=''  "  AND  PROV2.NUH$<>“  “  THEN  124 

094A  16F2  IF  PROV2.PFX$<>"  "  AND  PROV2.NUM$=«  “  THEN  124 

0970  16f2  GOTO  125 

0974  16F2 

0974  16F2  124  N.ERR  ^  N.ERR  *  1 

097C  16F2  ED.HSG$(N.ERR)-"PROV  2  CODE  MISSING  PREFIX  OR  NUMBER  IN  PART''*IXS 

0995  16F2 

0995  16F2  REM  ***  SECONDARY  PROVIDER  TIME 

0995  16F2  125  X»VAL{MIO$<TEXT$,P2T.OFFSET+POINTER,1)) 

09B0  16F2  PR2.TIMS(I910)>PROVIDER.TIMES(X) 

09CO  16F2  REM  IS  THERE  A  TIME  AND  NO  SEC  PROV  COOED? 

09C0  16F2  IF  PR2.TIM$(I910)<>“000"  AND  PB«1  THEN  126 

09FA  16F2  REM  IS  THERE  NO  TIME  AND  A  SEC  PROV  COOED? 

09FA  16F2  IF  PR2.TIMt< I910)="000“  AND  PB*0  THEN  127 

0A27  16F2  GOTO  128 

0A2B  16F2 

0A2B  16F2  126  N.ERR  >  N.ERR  +  1 

0A33  16F2  ED.MS6$(N.ERR)s''TIM£  COOED  WITH  NO  SEC  PROV  COOED  IN  PART"+IXS 

0A4C  16F2  GO  TO  128 

0A50  16F2 

0A50  16F2  127  N.ERR  =  N.ERR  ♦  1 

0A58  16F2  EO.MSG$(N.ERR)="NO  PROV  2  TIME  IN  PART"+IX$ 

0A71  16F2 

0A71  16F2  REM  •••  REASON  FOR  #2  CARE  PROVIDER 

0A71  16F2  128  SPROV.REA$(I910)=MID$(TEXT$,REA.OFFSET*POINTER,1) 

0A94  16F2  REM  IS  THERE  A  REAS  AND  NO  SEC  PROV  CODED? 

0A94  16F2  IF  SPROV.REAt< I910)o"  "  AND  P8=1  THEN  129 

0AC1  16F2  REM  IS  THERE  NO  REAS  AND  A  SEC  PROV  COOED? 

0AC1  16F2  IF  SPROV.REA$<I910)="  "  AND  PB-0  THEN  130 

OAEE  16F2  GOTO  131 

0AF2  16F2 

0AF2  16F2  129  N.ERR  =  N.ERR  ♦  1 

OAFA  16F2  ED.MSG$(N.ERR)="REASON  COOED  WITH  NO  SEC  PROV  COOED  IN  PART"+IX$ 

0813  16F2  GO  TO  131 

0817  16F2 

0B17  16F2  130  N.ERR  =  N.ERR  ♦  1 

081F  16F2  EO.MSGS(N.ERR)-"NO  PROV  2  REASON  IN  PART"«IXS 

0B38  16F2 

0B38  16F2 

0B38  16F2  REM 

0B38  16F2  131 

0B41  16F6 

0BS8  16F6 

0B6F  16F6 

0B86  16F6 


0B9A 

16F6 

0B9A 

16F6 

REM 

•••  ADDITIONAL  PROCEDURE 

0B9A 

16F6 

132 

ADOPS=MIO$(TEXTS,U^R.OFFSET*POINTER,5) 

0BB1 

16FA 

0BB1 

16FA 

REH 

•••  PRC'EDURE  COOES  FOR  PROV  1 

08S1 

I6fA 

134 

X$  =  M[DS(rEXrS,PRC.OFfSET«POINrER,N.PROC> 

VISIT  COUNT  *** 

VCNTS="1"  'DEFAULT 

XS=MIDS(TEXT$,VCT.OFFSET+POINTER,1) 
IF  XS="1"  THEM  VCNT$="0" 

IF  Xl>"1"  THEM  VCNTt=X$ 
VIS.CMTS(I910)=VCNTS 
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0BC9 

16FA 

GOSUB  6000  'DECODE  THE  X$  STRING 

OBOE 

16FA 

IF  TOT  >  0  THEN  GOTO  135 

OBOO 

16FC 

FOR  I910.A«  1  TO  TOT 

OBEA 

16FE 

PTR«VAL(HOU>S(I910.A)) 

OCOO 

1702 

GROUP1${I910,I910.A)»PROCED$<PTR) 

0C22 

1702 

NEXT  I910.A 

0C33 

1702 

0C33 

1702 

REN 

...  ADO  UNLISTED  CODE  IF  THERE  TO  PROV  1  ... 

0C33 

1702 

135 

IF  AOOPS*"  "  THEN  136 

0C41 

1702 

T0T=T0T+1 

0C49 

1702 

GROUPISf 1910, TOT I^ADOPS 

0C62 

1702 

0C62 

1702 

136 

T07.PR0C1<I910)*TOT 

0C71 

1702 

0C71 

1702 

REM 

*•*  PROCEDURE  COOES  FOR  PROV  2 

0C71 

1702 

138 

XS  >  MI0$(TEXT$,PC2.OFFSET'^POlNTER,N.PROC> 

0C89 

1702 

GOSUB  6000  'DECODE  THE  XS  STRING 

0C8E 

1702 

IF  TOT  >  0  THEN  GOTO  140 

0C90 

1702 

IF  PB=1  THEN  141  ‘ERROR  If  PROV  2  CODE  BLANK 

0CA8 

1702 

FOR  I910.A»  1  TO  TOT 

0CB5 

1704 

PTR=VAL(HOL0$(I910.A)) 

0CC8 

1704 

GRaUP2S( 1910, 1910. AlcPROCEDStPTR) 

OCEO 

1704 

NEXT  1910. A 

OCfE 

1704 

OCFE 

1704 

140 

TOT.PROC2(I910)*TOT 

0000 

1704 

GOTO  142 

0011 

1704 

0011 

1704 

141 

N.ERR  =  N.ERR  +  1 

0019 

1704 

ED. 

.MSGS(N.ERR)-''PROC  FOR  SEC  PROV  BUT  NO  SEC  PROV  CODED  IN  PART^'^-IXS 

0032 

1704 

0032 

1704 

142 

POINTER  =  POINTER  ♦  TOT.OFFSET 

0030 

1704 

NEXT  1910 

004F 

0050 

00  50 

1704 

1704 

1704 

199 

REM 

0050 

1704 

0050 

1704 

0050 

1704 

IF  N.ERR  a  0  THEN  GOTO  997 

005F 

1704 

LPRINT  "LITHO  #  ";LITHO$,-"  ...  ERRORS" 

0071 

1704 

FOR  1997  =  1  TO  N.ERR 

00 7E 

1706 

LPRINT  USING  "###  «;I997; 

008A 

1708 

LPRINT  "==>  ";E0.MSC$(I997) 

OOAO 

1708 

NEXT  1997 

GOBI 

1708 

LN. COUNT  =  LN. COUNT  ♦  N.ERR  ♦  1 

0060 

170a 

CNTRLOPT  =  6 

0DC4 

170A 

GOSUB  9010  'REJECT  THE  FORM 

00C9 

170a 

GOTO  998  'BYPASS  THE  DISK  WRITER,... 

ODCO 

170A 

ooco 

170  a 

997 

REM  SINCLUDE:  'RACM920.Ha2'  REH  INCLUDE  THE  BASE  ENCOUNTER 

FORM  1 

OOCE 

170A 

REM 

OOCE 

170A 

REM 

AMBULATORY  CARE  INFORMATION  SYSTEM  13  MAR  87 

*«*« 

01CE 

170A 

REM 

»•*•  D  R  BOLLING 

OOCE 

170a 

REM 

***•  MODULE  NAME  :  RACM920.MO2 

•  *** 

OOCE 

170A 

REH 

SCANNER  PROGRAM  #  :  920-  PT  REPEAT  VISIT  FORM 
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OOCE 

170A 

OOCE 

170A 

OOCE 

170A 

OOCE 

170A 

OOCE 

170A 

OOCE 

170A 

OOCE 

170A 

OOCE 

170A 

OOCE 

170A 

OOCE 

170A 

OOCE 

170A 

OOCE 

170A 

OOCE 

170A 

OOCE 

170A 

OOCE 

iroA 

OOCE 

170A 

OOCE 

170  A 

OOCE 

170A 

OOCE 

170A 

0005 

170A 

0C05 

1710 

0E10 

1710 

0E4O 

1714 

0E91 

1718 

0EC2 

171C 

OE05 

171C 

OEOA 

171C 

0EE5 

171C 

0EF7 

171C 

0EF7 

171C 

0EF7 

171C 

0EF7 

171C 

0EF7 

171C 

0EF7 

171C 

0EF7 

171C 

0EF7 

171C 

0EF7 

171C 

OEFE 

171C 

0F12 

171E 

0F42 

171E 

0F5A 

171E 

0F8A 

171E 

OFAE 

171E 

0FB3 

171E 

OFBE 

171E 

0FD2 

171E 

0FE4 

171E 

0FE4 

171E 

0FE4 

171E 

0FE4 

171E 

OFEB 

171E 

OFFF 

1720 

102F 

1720 

1047 

1720 

Source  Line 
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REM 

REM 

REM 

REM 

REM 

REM 

REM 

REM 


PURPOSE 


CREATE  AND  WRITE  THE  DISK 
RECORD  FOR  INPUT  TO  FOCUS 


***« 


****  PROGRAM  ADOS  PREFIX  TO  LtTHO  FOR  EACH  PATIENT 


RESERVED  LINE  NUMBERS  200-299 

*«*•«*••**'***««••**■*•***«•**#*«*««•••••**«««•***«  **************^*** 


REM  BUILD  THE  OUTPUT  RECORD 


REM 

REM 

REM 

REM 


********* 


*•******«*«*****•******************************< 

RECORD  TYPE  “1"  -  RECKEY  PLUS  TYPE  1  FIELDS 

s****************************************************************** 

RECOUTS  <‘‘9201'HRECKEYS  'TRANSACTION  IDENTIFIER 


REM  ...  TYPE  1  RECORD  ... 


FOR  IK  <  1  TO  4 

RECKEYS  »  CL 1. COOS  ♦  VDATS<IK)  «PR1 .COOS(IK)  ♦  SSNS  ♦  FMEMPS 
IF  VDATS(IK)  «  »  «  THEM  240 

RECOUTS  »  ••9201''  ♦  RECKEYS  ♦  RIGHTS<STRS<IK),1)  ♦  RIGHTS(LITHO$,7) 
TYPE1S  *  "92“  ♦  VIS.CHT$(IK)»PR1.T!MS(IK)+PR2.C00S(IK)*PR2.TIMS(IK) 
TYPEIASa  SPROV.REASCIK)  ♦  »  "  ♦  REF. COOS  ♦  STRIMO$(11,"  ")  ♦  PRIMDXS 
RECOUTS  *  RECOUTS  +  TYPEIS  ♦  TYPE1AS 
GOSU8  280 
PRINT  #1, RECOUTS 
240  NEXT  IK 

REM 

REM  ••••  RECORD  TYPE  "2"  -  RECKEY  PLUS  PROCEDURE  CODE  • 

REM 

REM  RECOUTS  >"9202"+RECKEYS  'TRANSACTION  IDENTIFIER 

REM  ...  PROCEDURES  OF  FPST  PROVIDER  ... 

FOR  1910  =  1  TO  4 

FOR  1910. A  =  1  TO  TOT.PROC1(I910) 

RECKEYS  =  CLI.COOS  +  VOATS<I910)  ♦PR1 .C00$( 1910)  ♦  SSNS  ♦  FMEMPS 
IF  VOAT$(I910)  =  "  "  THEN  250 

RECOUTS  =  "9202"  ♦  RECKEYS  ♦  RIGHT$(STRS{I910),1)  ♦  RICHTS(LITH0$,7) 
RECOUTS  =REC0UTS  ♦  "921"  ♦  GR0UP1$(I910, I910.A> 

GOSUB  280 
PRINT  *1, RECOUTS 
NEXT  1910. A 
250  NEXT  1910 

REM  ...  PROCEDURES  OF  SECOND  PROVIDER  ... 

FOR  1910  =  1  TO  4 

FOR  1910. A  =  1  TO  TOT.PROC2(I910) 

RECKEYS  =  CLI.COOS  ♦  VDATS(I910)  ♦PR1  .COOS< 1910)  ♦  SSNS  ♦  FMEMPS 
IF  VDATS(I910)  =  "  "  THEN  260 

RECOUTS  =  "9202"  ♦  RECKEYS  ♦  RIGHTS(STRS(I910),1)  ♦  RIGHTS(LITHOS,7) 
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10FB 
10FB 
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1116 
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1117 
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1117 
1117 
1117 
1117 
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1117 
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Data 

Sourt 

1720 

1720 

1720 

1720 

1720 

260 

1720 

1720 

GOTO 

1720 

1720 

REM 

1720 

REM 

1720 

REN 

1720 

280 

1722 

1722 

1722 

1722 

1722 

299 

1722 

1722 

REM 

1722 

1722 

998 

1722 

1722 

999 

1722 

1722 

1722 

1722 

REM 

1722 

1722 

1000 

1722 

REM 

1722 

REM 

1722 

REM 

1722 

REM 

1722 

REM 

1722 

REM 

1722 

REM 

1722 

REM 

1722 

REM 

1722 

REM 

1722 

REM 

1722 

REM 

1722 

1001 

1722 

1722 

172E 

172E 

172E 

172E 

172E 

172E 

172E 

172E 

172E 

1002 

172E 

09:28:25 

IBM  Personal  Coiaputer  BASM.  Coffin' ler  VI. 00 


RECOUTS  >RECOUTS  *  >922>  *  (iROUP2S(I910, 1910.A) 
G0SU8  280 
PRINT  «1, RECOUTS 
NEXT  I910.A 
NEXT  1910 


A****************************************************************** 

SUBROUTINE  280  -  PAD  THE  RECORD  TO  MAXLENCTH 


PAO>HAXLENGTH  -  LEN(RECOUTS)  'FIND  OUT  HOU  SHORT  THE  RECORD  IS 
RECOUTS  ■  RECOUTS  *  STRINGSCPAD.PADS)  'PAD  THE  RECORD  WITH  FILL  CHAR 
RETURN 


•END  OF  HOOULE  RXXM920.H02- 


REAOTYPE  >  2 

IF  LN. COUNT  >  48  THEN  GOSUB  7100 
GOTO  10 


•PRINTER  HEADING 


REM  ENO  OF  SCAN/DECOTE/URITE  LOOP  =•«=«==»==== 


REN  SINCLUDE:  'RACS 1000. SUB*  INCLUDE  THE  VERIFY  LOGON  SUB 


LOGON  VERIFICATION  SUBROUTINE 
PATIENT  REGISTRATION  PROGRAM 

**•««#*****««««****•***«*«****•*****«*•* 

PATIENT  OMR  INPUT  PROGRAM 


RESERVED  LINE  NUMBERS  ARE  1001  THRU  1010 


IF  EOF(1)  THEN  1002 
INPUT  #1,USER$(1},DT$,TM$,PIDS 
IF  USERS(I)  =  "«  THEN  1002 
IF  USERSd)  •  «•••*••»  then  1002 
CLOSE  1 

SCREEN  0,1, 0,0 
COLOR  FORE, BACK, BORO 
CLS 
RETURN 


CHAIN  "RACP05" 


•MAKE  THEM  LOG  ON  FIRST 


•MAKE  THEM  LOG  ON  FIRST 
•MAKE  THEM  LOG  ON  FIRST 
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Offset 

Data 
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IBM  Personal  Computer  BASIC  Compiler  VI. 00 

11B9 

172E 

*asss 

*=»====EMD  OF  LOGON  VERIFY  SUBROUTINE  1000«»««»»«»»»=»»*»»“»****»**»* 

11B9 

172E 

11B9 

172E 

2000 

REM  S INCLUDE:  'RACSaOOO.SUB' 

INCLUDE  THE  REPLY/DELAY  SUB 

11BA 

172E 

REM 

****««****«••••**««*««*«•««*««••••••***•«•*•«••*•**•*«**•********** 

11BA 

172E 

REM 

***• 

AMBULATORY  CARE  DATA 

BASE  13  APR  SS 

11BA 

172E 

REM 

**•* 

SKIP  COLE 

11BA 

172E 

REM 

SUBROUTINE  NAME 

RACS2000.SU8 

11BA 

172E 

REM 

***« 

SCANNER  PROGRAM  » 

ALL 

*«** 

11BA 

172E 

REM 

**** 

FUNCTION 

THIS  SUBROUTINE  MODULE 

11BA 

172E 

REM 

**** 

SERVERS  AS  A  UAIT  AND  REPLY 

**** 

11BA 

172E 

REM 

ENTRY  MODULE 

11BA 

172E 

REM 

**** 

INPUT 

SINGLE  KEYBOARD  ENTRY 

**** 

11BA 

172E 

REM 

11BA 

172E 

REM 

*«•* 

OUTPUT 

KEYBOARD  ENTRY  -  UPPER  CASE 

11BA 

172E 

REM 

**** 

11BA 

172E 

REM 

**** 

RESERVED  LINE 

**** 

11BA 

172E 

REM 

**** 

NUMBERS 

2001-2010 

11BA 

172E 

REM 

*«*«««* 

1**** 

tIBA 

172E 

2001 

REM  REPLY  FUNCTION 

11BB 

172E 

2002 

REPLYSsINKEYS  ;  IF  REPLY$»“"  THEN  2002 

11CF 

1732 

REPLY=ASC(REPLYS) 

1109 

1734 

IF  REPLY 

>  90  THEM  REPLYS»CHR$(REPLY  XOfi  32)  'CONVERT  TO  CAPS 

11F4 

1734 

IF  REPLYS  <  "A"  OR  REPLYS  >  “2"  THEN  REPLYS*“7" 

1220 

1734 

RETURN 

1223 

1734 

1223 

1734 

5000 

REM  SINCLUOE:  ■ RACS5000 . SUB ' 

INCLUDE  THE  DATE  EDITOR  SUB 

1224 

1734 

REM 

122' 

1734 

REM 

AMBULATORY  CARE  DATA 

BASE  13  APR  85 

1224 

1734 

REM 

•  *«« 

SKIP  COLE 

1224 

1734 

REM 

**•« 

SUBROUTINE  NAME 

RXXS5000.SU8 

1224 

1734 

REN 

SCANNER  PROGRAM  « 

ALL 

1224 

1734 

REM 

«««* 

FUNCTION 

THIS  SUBROUTINE  MODULE 

***• 

1224 

1734 

REM 

PERFORMS  A  DATE  EDIT 

1224 

1734 

REM 

**«* 

*«•* 

1224 

1734 

REM 

INPUT 

DATE  TO  BE  CHECKED  MUST  BE 

1224 

1734 

REM 

IN  THE  VARIABLE  NAMED 

1224 

1734 

REM 

«*-** 

•CK.SOOOS' 

1224 

1734 

REN 

***• 

IN  THE  FORMAT  "YYMMDO" 

**** 

1224 

1734 

REM 

1224 

1734 

REM 

**** 

OUTPUT 

:  'RT.5000'  IS  THE  RETURN  CODE 

1224 

1734 

REM 

*«** 

VARIABLE.  IF  THIS  VARIABLE 

**** 

1224 

1734 

REM 

***« 

CONTAINS  ANY  NUMBER  OTHER 

•*** 

1224 

1734 

REN 

•*** 

THAN  0,  AN  ERROR  UAS  FOUND 

***• 

1224 

1734 

REM 

*«** 

IN  THE  DATE. 

•  *** 

1224 

1734 

REN 

1224 

1734 

REM 

**** 

RESERVED  LINE 

•*** 

1224 

1734 

REM 

***• 

NUMBERS 

:  5001-5009 

•  *«* 

1224 

1734 

REM 

1224 

1734 

RT. 

5000  =  0 

122B 

1734 

CKYEAR  =  VAL(LEFT$(CK.5000$,2))  'TEAR  NUMERIC  VALUE 

123E 

1736 

CKMONTH  =  VAL(MID$(CK.5000$,3,2))  'MONTH  NUMERIC  VALUE 

1254 

1738 

CKDAY  =  VAL<RIGHT$(CK. 

5000$, 2))  'DAY  NUMERIC  VALUE 

1257 

173A 

1267 

173A 

IF  CKMONTH  <  1  THEN  RT. 5000=1  :  GOTO  5009 

RACP920 
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Offset 
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IBM  Personal  Conputer  BASIC  Conpiler  VI. 00 

127D 

173A 

IF  CKMONTH  >  12  THEN  RT.5000>1  :  GOTO  5009 

1293 

173A 

IF  CRDAY  <  1  THEN  RT.500a>2  :  GOTO  5009 

12A9 

173A 

IF  CXDAY  >  31  THEN  RT. 5000-2  :  GOTO  5009 

12BF 

173A 

12BF 

173A 

REM 

LEAP  YEAR  CHECK 

12BF 

173A 

HOLENGTH(2)  -  28 

12C6 

173A 

IF  CKMONTHo  2  THEN  GOTO  5005  ‘MUST  BE  FEBRUARY 

1205 

173A 

IF  (CKYEAR  MOD  4}  <>  0  THEN  GOTO  5005  'MUST  BE  A  LEAP  YEAR 

12EA 

173A 

HOLENGTH<2)  -  29 

12F1 

173A 

12F1 

173A 

5005 

IF  CKDAY  >  NOLENGTH (CKMONTH) 

THEN  RT. 5000-3  :  GOTO  5009 

1310 

173A 

1310 

173A 

5009 

RETURN 

1313 

173A 

1313 

173A 

1313 

173A 

5010 

REM  SINCLUDE:  •RACS5010.SUB' 

INCLUDE  THE  NUMERIC  STRING  EDITOR 

1314 

173A 

REM 

1314 

173A 

REM 

*"*  AMBULATORY  CARE  DATA  BASE  1  MAY  85 

***• 

1314 

173A 

REM 

«««* 

SKIP  COLE 

***• 

1314 

173A 

REM 

SUBROUTINE  NAME 

RXXS5010.SU8 

***# 

1314 

173A 

REM 

SCANNER  PROGRAM  «  ; 

ALL 

1314 

173A 

REM 

FUNCTION  : 

THIS  SUBROUTINE  MODULE 

•*** 

1314 

173A 

REM 

***« 

PERFORMS  A  NUMERIC  STRING 

*•** 

1314 

173  A 

REM 

«««« 

EDIT. 

•••* 

1314 

173  A 

REM 

1314 

173A 

REM 

•***  INPUT  ! 

STRING  TO  BE  EDITED  IS  IN 

*•** 

1314 

173A 

REN 

THE  VARIABLE  NAMED 

•*** 

1314 

173A 

REM 

««** 

•CK.5010$' 

**** 

1314 

173A 

REM 

***• 

1314 

173A 

REM 

••••  OUTPUT  ; 

<RT.5010'  IS  THE  RETURN  CODE 

1314 

173A 

REM 

«**« 

VARIABLE.  IF  THIS  VARIABLE 

1314 

173A 

REM 

CONTAINS  ANY  NUMBER  OTHER 

***• 

1314 

173A 

REN 

**** 

THAN  0,  AN  ERROR  WAS  FOUND 

**•* 

1314 

173A 

REM 

IN  THE  STRING. 

**** 

1314 

173A 

REM 

•■**« 

**•* 

1314 

173A 

REM 

RESERVED  LINE 

***« 

1314 

173A 

REM 

••••  NUMBERS  ; 

5011-5019 

«*** 

1314 

173A 

REM 

1314 

173A 

RT.5010  =  0 

131B 

173A 

131B 

173A 

FOR  15010  -  1  TO  LEN(CK.5010$) 

132B 

173C 

J5010-  ASC(MIDS(CK.5010$, 

15010,1)) 

133F 

1740 

IF  J5010  <  48  OR  J5010  > 

57  THEN  RT.5010  =  RT.5010  ♦  1 

1367 

1740 

NEXT  15010 

y 

1378 

1740 

■378 

137B 

1740 

1740 

RETURN 

137B 

1740 

5500 

REM  INCLUDE:  'RACS5500.SUB' 

INCLUDE  THE  OUTPATIENT  UCA  CHECK 

SUB 

137C 

1740 

137C 

1740 

6000 

REM  SINCLUDE:  ' RACS6000 . SUB ' 

INCLUDE  THE  INSTRING  DECODE  ROUTINE 

137D 

1740 

REM 

I37a 

1740 

REM 

****  AMBULATORY  CARE  DATA 

BASE  13  APR  85 

1370 

1740 

REM 

**** 

SKIP  COLE 

RACP920 

PT  REPEAT  VISIT  FORM 


PAGE  15 
(K-28-87 
09:28:25 


Offset 

Data 

Source  Line 

16 

137D 

1740 

REN 

*«*« 

SUBROUTINE  NAME  RXXSOOOO.SUB 

*««* 

1370 

1740 

REM 

**** 

SCANNER  PROGRAM  «  ALL 

**«* 

1370 

1740 

REM 

FUNCTION  :  THIS  SUBROUTINE  MODULE 

**** 

1370 

1740 

REM 

PERFORMS  INSTRING  SEARCH 

*•«* 

1370 

1740 

REM 

1370 

1740 

REM 

INPUT  :  STRING  TO  BE  SEARCHED  MUST 

*•«* 

1370 

1740 

REM 

BE  IN  THE  VARIABLE  NAMED  : 

*•«* 

1370 

1740 

REM 

•X$‘ 

1370 

1740 

REM 

*«** 

***« 

1370 

1740 

REM 

**•* 

OUTPUT  :  'TOT'  ■  TOTAL  NUMBER  OF 

*«** 

1370 

1740 

REM 

HITS  IN  THE  DESTRIHG 

•*** 

1370 

1740 

REM 

•••« 

■HOLOSO'  IS  THE  ARRAY 

**** 

1370 

1740 

REM 

CONTAINING  THE  NUMERIC 

*•** 

1370 

1740 

REM 

VALUE  Of  THE  HIT  POSITIONS 

**** 

1370 

1740 

REM 

*««* 

**•* 

1370 

1740 

REM 

1370 

1740 

REN 

RESERVED  LINE 

***• 

1370 

1740 

REN 

*«** 

NUMBERS  :  6001-6009 

*•** 

1370 

1740 

REM 

•*«***•««•*•**«**««**•*«*«•«•*••«•*•«•««*«•««••••****•********•**••* 

1370 

1740 

6001 

PTR  *  IMSTR<X$,"1") 

138B 

1740 

TOT  »  0 

1392 

1740 

WHILE  PTR  >  0 

1390 

1740 

TOT»TOT*1 

13A5 

1740 

HOLDSITOT)  s  RIGHTS(STRS(PTR),2) 

13C7 

1740 

PTR=PTR+1 

13CF 

1740 

PTR  =  INSTR(PTR,X$,"1“) 

13E1 

1740 

UENO 

13E5 

1740 

RETURN 

13E8 

1740 

17E8 

13E8 

1740 

13E8 

1740 

13E8 

1740 

7000 

REM  SINCLUOE:  ' RACS7000 . SUB '  INCLUDE  THE  SCREEN  HEADER  SUB 

13E9 

1740 

REM 

«««***« 

***** 

13E9 

1740 

REM 

AMBULATORY  CARE  DATA  BASE  13  APR  85 

**** 

13E9 

1740 

REM 

SKIP  COLE 

**** 

13E9 

1740 

REM 

•«*« 

SUBROUTINE  NAME  :  RACS7000.SUB 

**** 

13E9 

1740 

REM 

SCANNER  PROGRAM  *  :  ALL 

**** 

13E9 

1740 

REM 

**** 

FUNCTION  :  THIS  SUBROUTINE  MODULE 

**** 

13E9 

1740 

REM 

*•*« 

PRINTS  THE  STANDARD  SCREEN 

**** 

13E9 

1740 

REM 

HEADING. 

**** 

13E9 

1740 

REM 

•**« 

INPUT  :  COMMON  VARIABLE  USERS(2) 

**** 

13E9 

1740 

REM 

■  SYSTEM  DATE 

**** 

13E9 

1740 

REM 

**** 

13E9 

1740 

REM 

•  *** 

OUTPUT  :  SCREEN  HEADING 

**** 

13E9 

1740 

REM 

**** 

13E9 

1740 

REM 

•••« 

RESERVED  LINE 

**** 

13E9 

1740 

REM 

«*** 

NUMBERS  :  7001-7010 

**** 

13E9 

1740 

REM 

******* 

***** 

13E9 

1740 

13E9 

1740 

7001 

LOCATE  1 

,1 

13f3 

1740 

PRINT  "U 

•  S.  ARMY  AMBULATORY  CARE  INFORMATION  SYSTEM" 

13FB 

1740 

LOCATE  1 

.65 

1408 

1740 

PRINT  OATES; 
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142A 

1420 

Oats 

1740 

1740 
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LOCATE  2.1 

PRINT  •niSER  ;  ■.•USERSd) 

RETURN 

7100  REH  SINCLUDE:  ■RACS7100.SUB'  INCLUDE  THE  PRINTER  HEADER  SUB 

IBM  Personal  Conputer  BASIC  Cctipiler  VI. 00 

142E 

1740 

REM 

AMBULATORY  CARE  DATA  BASE  13  APR  85 

142E 

1740 

REM 

SKIP  COLE 

'42E 

1740 

REM 

*««* 

SUBROUTINE  NAME  RXXSriOO.SUB 

*•** 

142E 

1740 

REM 

*«** 

SCANNER  PROGRAM  «  :  ALL 

•*«* 

142E 

1740 

REM 

FUNCTION  :  THIS  SIAROUTINE  MODULE 

142E 

1740 

REM 

•**« 

PRINTS  THE  STANDARD  HEADING 

142E 

1740 

REM 

**** 

OH  THE  PRINTER. 

142E 

1740 

REM 

*«** 

INPUT  DATE, PAGE. PGMIDS.PGMTITLS 

*«*« 

142E 

1740 

REM 

142E 

1740 

REM 

*«•* 

OUTPUT  :  PRINTER  HEADING,  LN. COUNT 

142E 

1740 

REM 

**•* 

142E 

1740 

REM 

RESERVED  LINE 

142E 

1740 

REM 

•  «*« 

NUMBERS  :  7101-7110 

142E 

1740 

REM 

'•42E 

1740 

7101 

IF  PAGE  >  0  THEN  LPRINT  CHR$<12); 

1444 

1740 

LPRINT 

“ARMY  AM8UUTORY  CARE  INFORMATION  SYSTEM....  “.-PGHTITLS; 

1451 

1740 

LPRINT  TAB{70);OATE$ 

1464 

1740 

PAGE^PAGE'^I 

146C 

1740 

LPRINT 

“PROGRAM  ";PGMI0$;TAB{70);“PAG£“; 

1489 

1740 

LPRINT 

USING  "«#«#<■; PAGE 

1495 

1740 

LPRINT 

1490 

1740 

LM.COUMT=3 

14A4 

1740 

RETURN 

14A7 

1740 

14A7 

1740 

8000 

REH  SINCLUDE:  'RACSSOOO.SUS*  INCLUDE  THE  DECODE  SUB  GROUP 

UAS 

1740 

REM 

14  AS 

1740 

REH 

**«« 

AMBULATORY  CARE  DATA  BASE  13  APR  85 

•  ** 

t4A8 

1740 

REH 

SKIP  COLE 

*«* 

14A8 

1740 

REM 

***« 

SUBROUTINE  NAME  :  RXXS8000.SUB 

*** 

14A8 

1740 

REH 

SCANNER  PROGRAM  #  ALL 

«*• 

14A8 

1740 

REH 

FUNCTION  :  THIS  SUBROUTINE  MODULE 

**• 

14A8 

1740 

REH 

**«• 

IS  A  GROUPING  THAT  PERFORMS 

**• 

HAS 

1740 

REM 

*«*« 

VARIOUS  DECXING  FUNCTIONS 

*«« 

HAS 

1740 

REH 

•«** 

ON  THE  SCANNER  DATA 

*** 

HAS 

1740 

REH 

***« 

HAS 

1740 

REM 

8001  -  DECODE  THE  HEADER  POSITIONS  (POINTER  0-20) 

HAS 

1740 

REM 

8050  -  CHECK  FOR  END  OF  JOB 

*** 

ha: 

1740 

REH 

**«* 

8100  -  PRINT  THE  HEADER  DATA  ON  THE  SCREEN 

•  *« 

HAS 

1740 

REM 

**** 

8200  -  DECODE  THE  RESPONSE  POSITIONS  (POINTER  21-.. 

)  *** 

HAS 

1740 

REM 

(RETURNED  IN  TEXTS  STRING  VARIABLE) 

HAS 

1740 

REM 

HAS 

1740 

REM 

**** 

INPUT  :  SHEET  RECORD,  RECORD  LENGTH 

•  ** 

HAS 

1740 

REH 

*** 

HAS 

1740 

REM 

•«** 

OUTPUT  ;  'TEXTS'  TRING  VARIABLE 

*** 

HAS 

1740 

REM 

**•* 

*** 

HAS 

1740 

REM 

**** 

RESERVED  LINE 

*** 

has 

1740 

REM 

**** 

NUMBERS  :  8001-8500 

•  *« 

HAS 

1740 

REM 

RACP920 
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14A8 

1740 

14A8 

1740 

■DECOOE  THE  HEADER  ONLY 

HAS 

1740 

8001 

POINTER  •  0 

UAF 

1740 

RECORDPTR  *  VARPTR(SHEETREC(0)} 

1486 

1742 

FOR  J8000  >  1  TO  21 

1480 

1742 

8002 

TEXTt>  TEXTS4CHR$<PEEK(REC0R0PTR  ♦  POINTER)) 

14DB 

1742 

POINTER>POINTER4l 

14E3 

1742 

NEXT  J8000 

14F2 

1744 

PROGRAMS^  LEFTS(TEXTS,3) 

1501 

1748 

BATCHSs  HI0S(TEXT$,4,3) 

1513 

174C 

SERIALS^  MI0S(TEXTS.7,4) 

1525 

1750 

RUNIDS-  MIDS(TEXTS,11,1) 

1537 

1754 

FORHS>  MI0S(TEXTS.12,2) 

1549 

1758 

POCKETS:  M I DS( TEXTS, 14,1} 

1558 

175C 

SCANERR1S:MIDS(TEXTS,16,2) 

1560 

1760 

SCANERR2Sa4(  I  DS(  TEXTS,  18,2) 

157F 

1764 

SCANERR3S:H I0S( TEXTS , 20 , 2 ) 

1591 

1768 

GOTO  8500 

1595 

1768 

1595 

1768 

8050 

REM  CHECK  FOR  END  OF  J08/ENO  OF  BATCH 

1596 

1768 

IF  PROGRAMS  :  PGM IDS  THEN  GOTO  8500 

1SA8 

1768 

LPRINT  STRINGS<80,“»") 

15B6 

1768 

LPRINT 

158E 

1768 

LPRINT  "RECORDS  PROCESSED  ...  «;SERIALS 

15CB 

1768 

LPRINT  "STARTED  AT  .  ";BTIMES 

1508 

1768 

LPRINT  "ENDED  AT  .  ";TIMES 

15E5 

1768 

LPRINT  CHRS(12) 

15F0 

1768 

GOTO  30000 

15F4 

1768 

15F4 

1768 

8070 

REM  CHECK  FOR  SCANNER  ERRORS 

15F5 

1768 

IF  POCKETS  =  "  "  GOTO  8500 

1607 

1768 

LPRINT  LITHOS; 

160F 

1768 

LPRINT  "  ...  SCANNER  ERRORS  :  "; 

1617 

1768 

LPRINT  SCANERRIS;"  / 

1624 

1768 

LPRINT  SCANERR2S;"  /  "; 

1631 

1768 

LPRINT  SCANERR3S 

1639 

1768 

LN=LN+1 

1641 

176A 

GOTO  999 

1645 

176A 

1645 

176A 

8100 

REM  PRINT  THE  HEADER  VARIABLES  ON  THE  TUBE.... 

1646 

176A 

LOCATE  5,1:PRINT  "PROGRAM  ".'PROGRAMS; 

1660 

176A 

1660 

176A 

PRINT  "  BATCH  "/BATCHS; 

1660 

176A 

PRINT  "  RUN  ";RUH10S: 

167A 

176A 

PRINT  “  FORM  "; FORMS; 

1687 

176A 

PRINT  "  POCKET  ".'POCKETS 

1694 

176A 

GOTO  8500 

1698 

176A 

1698 

176A 

8200 

REM  DECOOE  THE  RESPONSE  POSITIONS 

1699 

176A 

POINTER  *  21 

16A0 

176A 

RECORDPTR  =  VARPTR(SHEETREC(0) ) 

16A7 

176A 

FOR  J8000  :  22  TO  RECORDLENGTH 

1684 

176C 

8202 

TEXTS  :  TEXTS+CHRS(PEEK(RECORDPTR  ♦  POINTER)) 

1602 

176C 

POINTER=POINTER+1 
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160A 

176C 

NEXT  J8000 

16EB 

176C 

16EB 

176C 

8500 

RETURN 

16EE 

176C 

16EE 

176C 

REM  -■ 

.  END  OF  RXXSaOOO.SUB  . 

16EE 

176C 

16EE 

176C 

9000 

REN  SINCLUDE:  •RACS9000.SUB'  INCLUDE  THE  SCANNER  CONTROL  SUB 

16EF 

176C 

REM 

*««•«*•*****■*•****«****«*«•««******•«*«*****•***•**«•***•*••******* 

|6EF 

176C 

REM 

**** 

AMBULATORY  CARE  DATA  BASE  13  APR  85 

***« 

16EF 

176C 

REN 

**** 

SKIP  COLE 

•**« 

16EF 

176C 

REM 

**** 

PROGRAM  NAME  :  RACS9000.SUB 

***• 

16EF 

176C 

REM 

SCANNER  PROGRAM  #  :  ALL 

16EF 

176C 

REM 

«■*** 

FUNCTION  :  THIS  SUBROUTINE  MODULE 

**** 

16EF 

176C 

REM 

CONTROLS  THE  SCANNER  I/O 

16EF 

176C 

REM 

«*** 

•*** 

16EF 

176C 

REM 

INPUT/OUTPUT  :  REFER  TO  THE  ASYNCHRONOUS 

16EF 

176C 

REM 

«*** 

COMMUNICATIONS  MANUAL  AND  THE 

16EF 

176C 

REM 

«*** 

PRE-RELEASEO  SOFTWARE  GUIDE 

***• 

16EF 

176C 

REN 

««*• 

**** 

16EF 

176C 

REM 

**** 

***** 

•6EF 

176C 

REM 

***• 

RESERVED  LINE 

**** 

16EF 

176C 

REM 

NUMBERS  :  9001-9100 

**** 

16EF 

176C 

REM 

*«** 

»««*«*•**•******«*«*•**«*•***«**«*•*•«****•*•«««**•*•••••« 

***** 

16EF 

176C 

16EF 

176C 

16EF 

176C 

REM 

«*** 

***** 

16EF 

176C 

REM 

««•* 

SUBROUTINE  9001  •  PROTOCOL  SETUP  FOR  SCANNER 

***** 

16EF 

176C 

REM 

ARGUMENTS:  PRESET  ...  SEE  BELOW 

***** 

16EF 

176C 

REM 

16EF 

176C 

9001 

REM 

UFO 

176C 

PROTOCOL (0)  -  9600  'BAUD  RATE 

16F7 

176C 

PROTOCOL(I)  =  78  'PARITY  (SEE  PAGE  4-8  OF  MANUAL) 

■8FE 

176C 

PROTOCOL(2)  »  8  'DATA  BITS 

1705 

176C 

PROTOCOL(3)  =  1  'STOP  BITS 

170C 

176C 

PR0T0C0L<4)  =  2  'RS-232  PORT 

1713 

176C 

PROTOCOL(S)  =  0  'WRITE  TIME-OUT 

171A 

176C 

PROTOCOL{6)  =  0  'READ  TIME-OUT 

1721 

176C 

1721 

176C 

ERRSTATS  >  SPACE$(60) 

1720 

176C 

ARGPTR  •  VARPTR(PROTOCOL<0)) 

1734 

176E 

CALL 

SETUP  (ARGPTR, ERRSTATS) 

1745 

176E 

ERRMSGS*"" 

174E 

176E 

IF  ASC(ERRSTAT$)  <>  64  THEN  ERRMSG$="SETUP  ERROR  "♦ERRSTATS 

176A 

176E 

GOTO  9100 

176E 

176E 

176E 

176E 

REM 

«*** 

***** 

176E 

176E 

REH 

**** 

SUBROUTINE  9010  -  CONTROL  OPTIONS  FOR  SCANNER 

176E 

176E 

REM 

**** 

ARGUMENTS:  CNTRLOPT 

***** 

176E 

176E 

REH 

**** 

CNTRLOPT  "  1  =  START  SCANNER  (SI) 

176E 

176E 

REH 

**** 

CNTRLOPT  =  2  =  STOP  SCANNER  (SO) 

***** 

176E 

176E 

REM 

**** 

CNTRLOPT  =  3  =  TERMINATE  COMMUNICATIONS  TO  SCANNER  (DC3) 

***** 

176E 

176E 

REM 

**** 

CNTRLOPT  =  4  =  CLEAR  TRANSPORT  PATH  (DC2) 

***** 

176E 

176E 

REM 

**** 

CNTRLOPT  =  5  =  SELECT  PRIMARY  STACKER  "31" 

***** 

176E 

176E 

REH 

CNTRLOPT  =  6  =  SELECT  SECONDARY  STACKER  "32" 

***** 

RACP920 
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176E 

176E 

REM 

*•••  CNTRLOPT  ■  7  »  POSITIVE  RESPONSE/SELECT  SCANNER  (0C1) 

***«• 

176E 

176E 

REM 

CNTRLOPT  =  8  *  REQUEST  STATUS  (ESC) 

•  ***« 

176E 

176E 

REM 

176E 

176E 

9010 

REM 

176f 

176E 

ERRSTATS  °  SPACES(60) 

177B 

176E 

CALL  CNTROL  (CNTRLOPT, ERRSTATS) 

178C 

176E 

ERRMSGS^"" 

1795 

176E 

IF  ASC(ERRSTATS)  <>  64  THEN  ERRMS6$-"CONTROL  ERROR  "-fERRSTATS 

17B1 

176E 

GOTO  9100 

17B5 

176E 

17B5 

176E 

REM 

17B5 

176E 

REM 

•  »•  SUBROUTINE  9020  -  SCAN  SHEET  CALL 

***** 

17B5 

176E 

REM 

***** 

17B5 

176E 

REM 

••••  ARGUMENTS:  REAOTYPE 

1785 

176E 

REM 

•••*  REAOTYPE  =  2  »  REQUEST  NEW  DOCUMENT  FROM  SCANNER 

17B5 

176E 

REM 

REAOTYPE  «  3  »  RETRANSMIT  CURRENT  OOClNtENT 

***** 

17B5 

176E 

REM 

•*«* 

17B5 

176E 

REM 

****  ARGUMENTS:  RECOROLENGTH 

17B5 

176E 

REM 

••••  NUMERIC  VARIABLE  SET  TO  THE  NUMBER  OF  CHARACTERS  TO  BE 

17B5 

176E 

REM 

••••  TRANSMITTED 

***** 

1785 

176E 

REM 

•••««««««*•*«•••«*«*««***«***•«*«**♦*•«**•••*«***♦*«#««••*•*••*«•*• 

1785 

176E 

9020 

REM 

1786 

176e 

ERRSTATS  >  SPACES(60) 

17C2 

176E 

RECORDPTR  >  VARPTR(SHEETREC(0)) 

17C9 

176E 

CALL  SCAN  (REAOTYPE, RECOROLENGTH, RECORDPTR, ERRSTATS) 

!7E2 

1766 

ERRMSGS="'' 

17E8 

176E 

IF  MID$(ERRSTATS,14,3)  *  "415"  THEN  ERRMSGSs"ESC“ 

180C 

176E 

GOTO  9100 

1810 

176E 

1810 

176E 

REM 

1810 

176E 

REM 

*•••  SUBROUTINE  9030  -  TRANSPORT  PRINT  CALL 

1810 

176E 

REM 

1810 

176E 

REM 

*•••  ARGUMENTS:  PRIHTPOS 

1810 

176E 

REM 

NUMERIC  VARIABLE  INDICATING  THE  STARTING  PRINT  POSITION 

1810 

176E 

REN 

VALUES  *  0  THRU  90 

1810 

176E 

REM 

•«** 

1810 

176E 

REM 

ARGUMENTS:  PSTRINGS 

1810 

176E 

REM 

TEXT  TO  BE  PRINTED  ON  THE  FORM 

1810 

176E 

REM 

**** 

1810 

176E 

REM 

NOTE:  THIS  ROUTINE  HAS  HO  EFFECT  UNLESS  THE  SCAM 

1810 

176E 

REM 

***•  HEADER  SHEET  IS  MARKED  'PRINTER  ON* 

1810 

176E 

REM 

1810 

176E 

9030 

REM 

1811 

176E 

ERRSTATS  =  SPACES(60) 

1810 

176E 

RECORDPTR  >  VARPTR(SHEETREC(0)) 

1824 

176E 

CALL  TPRINT(PRINTPOS, PSTRINGS, ERRSTATS) 

1839 

1774 

IF  ASC(ERRSTATt)  <>  64  THEM  ERRMSG$*"PRIMT  ERROR  "♦ERRSTATS 

1855 

1774 

GOTO  9100 

1859 

1774 

1859 

1774 

9100 

RETURN 

185C 

1774 

177^ 

185C 

1774 
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185C 

1774 

25000  REM  USER  TERMINATED  INPUT...  FILE  IS  NOT  TO  BE  USEOHIII 

1850 

1774 

LPRINT  niSER  TERMINATED  INPUT  ..  DATA  WILL  NOT  BE  USED!" 

1865 

1774 

LPRINT  OERASING  FILE  "iDATFILS 

1872 

1774 

BEEP 

1876 

1774 

CLS  :  PRINT  "USER  TERMINOATED  INPUT  ..  DATA  WILL  NOT  BE  USED  I" 

1882 

1774 

CLOSE 

1886 

1774 

OPEN  DAT FILS  FOR  OUTPUT  AS  «1 

1898 

1774 

PRINT  tlI1,STRINaS(REC0R0LENGTH,"X ')  'VOID  THE  FIRST  RECORD 

18AA 

1774 

CLOSE 

18AE 

1774 

18AE 

1774 

30000  REM 

18AF 

1774 

CLOSE 

18B3 

1774 

CHAIN  "RACP10" 

18BA 

1774 

END 

18BE 

1774 

18C1 

1774 
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001A  0002  REM  SLINESIZE:  132 

001A  0002  REM  SPAGESIZE:  66 

001A  0002  REM  STITLE:  'RACP930  ■ 

001A  0002  REM  SSUBTITLE:  'REPEAT  ENCOUNTER  DESTRING/DECOOE  PROGRAM' 

001 A  0002  REM  SPACE 


RACP930 

REPEAT  ENCOUNTER  OESTRING/OECOOE  PROGRAM 


Offset 

Data 

001A 

0002 

001 A 

0002 

001A 

0002 

001A 

0002 

001A 

0002 

001A 

0002 

001A 

0002 

001A 

0002 

001A 

0002 

noiA 

0002 

001A 

0002 

001A 

0002 

001A 

0002 

001A 

0002 

001A 

0002 

001A 

0002 

001A 

0002 

001A 

0002 

001A 

0002 

OOIA 

0002 

001A 

0002 

OOIA 

0002 

'•OIA 

0002 

OOIA 

0002 

OOIA 

0002 

001A 

0002 

OOIA 

0002 

OOIA 

0002 

OOIA 

0002 

OOIA 

0002 

OOIA 

0002 

OOIA 

0002 

OOIA 

0002 

UOIA 

0002 

OOIA 

0002 

OOIA 

0002 

OOIA 

0002 

OOIA 

0002 

OOIA 

0002 

OOIA 

0002 

OOIA 

0002 

OOIA 

0002 

OOIA 

0002 

OOIA 

0002 

OOIA 

0002 

OOIA 

0002 

OOIA 

0002 

OOIA 

0002 

OOIA 

0002 

001  •, 

0002 

OOIA 

0002 

OOIA 

0002 

CO'A 

0CQ2 

C01A 

0C02 
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REM  + . - . . 

REM  1  NAME:  RACP930  AMBULATORY  CARE  INFORMATION  SYSTEM  j 

REM  I  Date:  11  MAR  87  REPEAT  ENCOUNTER  FORM  | 

REM  I  0  R  BOLLING  | 

REM  . . . 

REM  REPEAT  ENCOUNTER  FORM  INPUT  PROGRAM 

REM 

REM  This  program  reads  the  REPEAT  ENCOUNTER  form  OHR  data,  converts  various 
REM  fields,  prints  an  error  report  and  produces  the  file: 

REM 

REM  VISIT. OAT 

REM 

REM  for  input  to  FOCUS.  NOTE  THAT  THIS  FILE  IS  OPENED  FOR  APPEND 
REM  each  time  the  program  is  run.  Thus,  if  the  file  does  not  exist, 

REM  records  will  be  added  to  the  front.  If  the  file  exists,  records 
REM  will  be  added  to  the  end  of  the  current  file.  It  is  intended  that 
REM  the  FOCUS  DIALOGUE  MANAGER  ROUTINE  which  loads  the  data  will  delete 
REM  the  data  file  after  the  load  has  been  successfully  accomplished. 

REM 

REM  If  there  is  no  valid  user  logged  at  the  time  of  execution,  this 
REM  program  will  chain  to  the  logon  program  RACP05,  otherwise, 

REM  the  program  chains  to  program  RACP10  on  exit. 

REM  SINCLUOE:  •RACOIM.HOO'  REM  INCLUDE  THE  DIMENSION  DEFINITIONS 


NAME:  RACOIM.HOO  DIMENSION  DEFINITIONS 

Date:  28  Feb  84  Written  by:  Floyd  Cole 


Dimensioned  variables  are  defined  in  this  file. 

It  is  an  included  file  so  ft  cannot  be  run  in  a  stand-alone, 
mode. 


This  program  segment  may  be  modified,  but  all  files  containing 
an  include  for  this  segment  must  be  re-compiled  in  order  to 
affect  the  changes  made  here. 

*♦****•*»**•  START  OF  DIMENSION  DEFINITION 


DEFINT  A-Z 

DIM  USER$(2),M0LEHGTH(12),DATEERR$(3) 
••**•♦******  END  OF  DIMENSION  DEFINITIONS 


REM  DIMENSION  STATEMENTS  UNIQUE  TO  THIS  PROGRAM 


DIM  SHEETREC(1750) 
DIM  PROTOCOL (7) 

DIM  ED.MSG$(30) 

DIM  CLINIC1 .PFXS(5) 
DIM  DIAG.PFXT(2) 

DIM  REFER. PFXS(6) 
DIM  PR0V.TIMES(21) 
DIM  CUBUBSdl) 

DIM  PVDCSC5) 


'(MAX.  SIZE  FOR  A  SHEET  FROM  THE  SCANNER) 
'(ARRAY  FOR  SERIAL  BOARD  SETUP  PARAMETERS) 
'(ERROR  MESSAGES  FROM  EDIT  ROUTINES) 
'(PREFIX  -B  0  F  G  S-  FOR  CLINIC  #1) 
'(DIAGNOSIS  PREFIX  TABLE) 

'(REFERRAL  PREFIX  TABLE  -A  B  C  D  F  S-) 

'TIME  SPENT 

'SINGLE  BUBBLE  CLINIC  CODE  TABLE 

'(HOLD  AREA  FOR  VISIT  ,.',TES  ANd  PROV  COOES) 


RACP930 
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OOIA 
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OOU 

OOIA 
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0002 

0002 

0002 

0002 

0C02 

0002 

0002 

0002 

0002 

0002 

0002 

0002 

0002 

0002 

0002 

0002 

0002 

0002 

0002 

0002 

0002 

0002 

0002 

0002 

0002 

0002 

0002 

0002 

0002 

0002 

0002 

0002 

0002 

0002 

0002 

0002 

0002 

0002 

0002 
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REM  SINCLUDE:  'KACCHN.MOO' 


REM  Include  the  COMMON  AREA  DEFINITION 


NAME:  RACCMN.HOO 
Date:  28  Feb  84 


COMMON  AREA  DEFINITION 
Written  by:  Floyd  Cole 


COMMON  AREA  DEFINITIONS  WILL  BE  HELD  IN  THIS  FILE.  IT  IS  AN 
INCLUDED  FILE  SO  IT  CANNOT  BE  RUN  IN  A  STANO*ALONE,  MODE. 

This  program  segment  may  be  modified,  but  all  files  containing 
an  include  for  this  segment  must  be  re*ca<ipiled  in  order  to 
affect  the  changes  made  here. 


•START  OF  COMMON  DEFINITIONS* 


COMMON  FORE, BACK, BOARD, HIDE, EFORE.EBACK, BELLS  'BASIC  SCREEN  COLORS 


COMMON  HEADERS 
COIMON  TEXTS 
COMMON  PGMIDS 
COMMON  MOLENGTHO 
COMMON  USERS! ) 
•••••••••••••END 


‘21  CHARACTER  SCANNER  HEADER  INFO 
"  AINING  CHARACTERS  FROM  SCANNER 
'PROGRAM  OR  FORM  ID 
■DAYS  IN  THE  MONTH 


OF  COMMON  DEFINITION* 


REM  SINCLUDE:  'RACDEF.MOO' 


REM  Include  the  DEFAULT  DEFINITIONS 


NAME;  RACP01.DEF 
Date:  28  Feb  84 


DEFAULT  DEFINITIONS 
Written  by:  Floyd  Cole 


Variables  used  in  connon  that  have  a  default  value  on  start*up 
will  be  held  in  this  file.  It  is  an  included  file  so  it  cannot 
be  run  in  a  stand*alone  mode.  In  normal  operation,  this  file 
should  be  'included'  in  the  main  program  only  (RACP10.BAS). 

This  program  segment  may  be  modified,  but  all  files  containing 
an  include  for  this  segment  must  be  re*compiled  in  order  to 
affect  the  changes  made  here. 


••♦♦•••••••••START  OF  DEFAULT  DEFINITION^ 


FORE  =  15 


■FOREGROUND  COLOR  <  INTENSE  WHITE 


0046 

0F2C 

BACK  :  1 

■Background  Color  »  Light  Blue 

0040 

0F2C 

BORD  :  4 

■BORDER 

<  RED 

0054 

0F2E 

HIDE  =  4 

■ALTERNATE  COLOR  =  RED 

■|05B 

0F2E 

EFORE*  14 

■ERROR 

FOREGROUND  DISPLAY 

0062 

0F2E 

EBACK=  0 

■ERROR 

BACKGROUND  DISPLAY 

0069 

0F2E 

BELLS  =  CHRS(7) 

‘Sounc 

the  bell 

0075 

0F2E 

0075 

0f2E 

MOLENGTHd) 

* 

31 

■JAN 

007C 

0F2E 

MOLENGTH(2) 

= 

28 

■FEB  <--MOOIFIED  IN  SUBROUTINE 

0083 

0F2E 

MOLENGTH(3) 

S 

31 

■MAR 

003A 

0F2E 

MOLENGTH(4) 

= 

30 

■APR 

0091 

0F2E 

MOLENGTH(5) 

= 

31 

■MAY 

0098 

0F2E 

MOLENGTH(6) 

= 

30 

■JUM 
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MOLENCTH(7)  »  31  ‘JUL 

MOLENGTHCS)  =  31  'AUG 

MOLENGTH(9)  «  30  'SEP 

MOLENCTHdO)  »  31  'OCT 

MOLEMGTHdl)  »  30  'NOV 

MOLENGTH(12)  >  31  'DEC 

DATEERRStO)  =  u  « 

DATEERRSd)  >  oiNVALIO  MONTH" 

DATEERR$<2)  -  "INVALID  OAT  " 

DATEERRSd)  s  "DAT  TOO  LARGE  FOR  MONTH  COOED" 


MAXLENGTH  -  80 

PADS  = 


•MAXIMUM  LENGTH  OF  OUTPUT  RECORD 
•PAD  CHARACTER  FOR  SHORT  RECORDS 


1  •************E),0  OF  DEFAULT  DEFINITION* 


REM  THE  FOLLOWING  VARIABLES  ARE  UNIQUE  TO  EACH  PROGRAM  ANO  MUST 
REN  BE  CHANGED. 


PGMTITLS  "  "REPEAT  ENCOUNTER  FORM" 


PGM  IDS  "  "930" 


•VALUE  RECEIVED  FROM  THE  SCANNER 
•IN  HEADER  VARIABLE  •PROGRAMS' 


OATFILS  =  "VISIT. OAT"  'FILE  TO  BE  INPUT  TO  FOCUS 

REM  LENGTH  OF  STRING  RECEIVED  FROM  THE  OMR.... 

HEADER  "  21 
RESPONSE^  97 

RECOROLENGTH  s  HEADER  +  RESPONSE 

N.PROC  =  1  '  NUMBER  OF  PROCEDURES  FOR  THIS  FORM 


BTIMES-TIMES 


•SCAN  START  TIME 


***  ENCOUNTER  FORM  CLINIC  PREFIX  TABLE  *** 
CLINIC  N1 

CLINIC1.PFX$(0)="?" 

CLINIC1.PFXSd)="B" 

CLINIC1.PFX$<2)="0" 

CLINIC1.PFXS(3)="F" 

CLINIC1.PFXS(4)="G" 

CLINIC1.PFXS(5)="S" 


*** 


DIAGNOSIS  PREFIX  TABLE 


RACP930 
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Offset 

Data 

Source  Line 

0170 

0F48 

0170 

0F48 

DIAG.PFX${0)="?“ 

0186 

0F48 

0IA0.PFX$(1)=«V" 

018F 

0F48 

DIAG.PFX$(2)«"S" 

0198 

0F4a 

0198 

0F48 

REM 

REFERRAL  PREFIX  TABLE 

0198 

0F48 

0198 

0F48 

REFER. PFX$(0)=“  " 

01A1 

0F48 

REFER. PFXS{1)«“A" 

01AA 

0F48 

REFER. PFXS(2)3'<B'' 

01 B3 

0F48 

REFER. PFX$(3)=«C» 

01BC 

0F48 

REFER. PFXS(4)*"0“ 

01C5 

0F48 

REFER. PFXt<S)="F" 

01 CE 

0F48 

REFER. PFXS(6)=''S" 

0107 

0F48 

0107 

0F48 

REM 

TIME  SPENT  TABLE 

*** 

0107 

0F48 

PROV.TIMES<00)=-'000‘' 

■NO  TIME 

01E0 

0F48 

PROV.TIME$<01)=“005“ 

■  5  MINUTES 

01E9 

0F48 

PROV.TIME${02)s“01Q" 

•10  MINUTES 

01F2 

0F48 

PROV.TIMES(03)="015'' 

•15  MINUTES 

01 FB 

0F48 

PROV.TIME$<04)»"020‘' 

•20  MINUTES 

0204 

0F48 

PROV.TIME$<05)«“030'' 

■30  MINUTES 

0200 

0F48 

PROV.TIME$(06)a«045« 

•45  MINUTES 

0216 

0F48 

PROV.TIMES(07)««060'' 

■  1  HOUR 

021 F 

0F48 

PROV.TIME$<08)s“090'' 

■  1.5  HOURS 

0228 

0F48 

PROV.TIME$<09)*"120" 

•  2  HOURS 

0231 

0F48 

PROV.TIME$(10)*"150" 

•  2.5  HOURS 

023A 

0F48 

PROV.TIME$(11)*"180" 

•  3  HOURS 

0243 

0F48 

PROV.TIMES(12)='<210'' 

•  3.5  HOURS 

024C 

0F48 

PROV.TIME${13)=''240" 

■  4  HOURS 

0255 

0F48 

PROV.TIMES(14)="270" 

•  4.5  HOURS 

025E 

0F48 

PROV.TIMES<15)="300" 

■  5  HOURS 

0267 

0F48 

PROV.TIME$<16)s"330" 

•  5.5  HOURS 

0270 

0F48 

PROV.TIME$(17)*"360" 

■  6  HOURS 

0279 

0F4a 

PROV.TIME$(18)*"390" 

•  6.5  HOURS 

0282 

0F48 

PROV.TIMEt(19)=:"420" 

■  7  HOURS 

0288 

0F48 

PROV.TIMEt(20)="450" 

■  7.5  HOURS 

0294 

0F48 

PROV.TIME$(21)»"480« 

■  8  HOURS 

0290 

0F48 

0290 

0F48 

REM 

SINGLE  BUBBLE  CLINIC  CODE  TABLE  ••• 

0290 

0F48 

CLIBUB$(1)="BABA"  : 

CLIBUBS(7)  s'^BFDA^^ 

02AF 

0F48 

CLIBUBS(2)=“BAJA''  : 

CLIBUB$(8)  •■•BHBA^^ 

02C1 

0F48 

CLIBUB$f3)=''BAXA"  : 

CLIBUBS(9)  3"DCBA^^ 

0203 

0F48 

CLIBUB$(4)="BALA"  : 

CLIBU8$<10)='^DHBA" 

02E5 

0F48 

CLIBUB$(5)="BAPA”  : 

CLIBUB$<11)="0H0A^^ 

02F7 

0F48 

CLIBUB$(6)="BFBA" 

0300 

0f48 

0300 

0F48 

REM 

INCLUDE:  'UCABAMC.OPT ■ 

INCLUDE  OUTPATIENT  UCA 

0300 

0F48 

0300 

0F48 

REM 

INCLUDE:  'UCABAMC. IPT' 

INCLUDE  INPATIENT  UCA 

0300 

0F4a 

0300 

0F48 

REM  SPACE 

table 

table 


PAGE  S 
07-06-87 
09:25:22 

IBM  Personal  Computer  BASIC  Compiler  VI.OO 


f  fCP930 

REPEAT  ENCOUNTER  DESTRIHG/DECOOE  PROGRAM 
Offset  Date  Source  Line 


PAGE  6 
07-06-87 
09:25:22 

IBM  Personal  Computer  BASIC  Compiler  VI. 00 


(• 


0300 

0F48 

GOSUB  1000  'HAKE  SURE  THEY  ARE  LOGGED  ON 

0305 

0F48 

CLS 

0309 

0F48 

GOSUB  7000  ‘PRINT  SCREEN  HEADING 

030E 

0F48 

030E 

0F48 

REM 

030E 

0F48 

REM 

*•••  OPEN  FILE  TO  CONTAIN  SCANNED  DATA  •••• 

030E 

0F48 

REM 

030E 

0F48 

REN 

J30E 

0F48 

OPEN  OATFILS  FOR  APPEND  AS  «1 

0320 

0F48 

0320 

0F48 

REM 

0320 

0F48 

REM 

*•••  CLEAR  AND  DISPLAY  PROGRAM  SCSEEN  •••• 

0320 

0F48 

REM 

«****««**«****•*•«*«*****«•«*•««*«***«*«**«****•««*«***«*«*****#*« 

0320 

0F48 

LPRINT  CHRS(IS); 

032B 

0F48 

UIOTH  '•LPT1:",160 

0335 

0F48 

PAGE  -  0  :  GOSUB  7100  ‘LINE  PRINTER  HEADING 

0341 

0F4A 

COLOR  14 

0348 

0F4A 

LOCATE  11,26  :  PRINT  “REPEAT  VISIT  FMH  " 

0350 

0F4A 

COLOR  FORE,BACK,BORD 

0373 

0F4A 

0373 

0F4A 

REM 

•*««*«***«««****««««**#******•*«*******•»*»»**•***»*****»•••«***«** 

0373 

0F4A 

REN 

COMMUNICATIONS  SETUP 

0373 

0F4A 

REM 

0373 

0F4A 

REM 

PROTOCOL 

0373 

0F4A 

GOSUB  9001 

0378 

0F4A 

IF  ERRMSGS  >  »  “  THEN  LPRINT  ERRHSGS  :  GOTO  30000 

0392 

0F4E 

0392 

0F4E 

REM 

START  SCANNER  (SI) 

0392 

0F4E 

CNTRLOPT  =1  : GOSUB  9010 

039E 

0F50 

IF  ERRMSGS  >  "  •■  THEN  LPRINT  ERRHSGS  :  GOTO  30000 

C3B8 

0F50 

03B8 

0F5O 

LOCATE  22,25:PRINT  "PRESS  'ESC  TO  TERMINATE  SCANNING  “ 

03CD 

0F50 

REA0TTPE*3  ‘FIRST  TIME  IN..  SCANNER  IS  STARTED.. 

0304 

0F52 

0304 

0F52 

REN 

0304 

0F52 

REM 

SET  SCAN  SHEET  CALL  •»»* 

0304 

0F52 

REM 

0304 

0F52 

REM 

0304 

0F52 

0304 

0F52 

10 

REM  -  RETURN  POINT  TO  READ  NEXT  SHEET 

0305 

0f52 

0305 

0F52 

AS: INKEYS 

03r  = 

0F56 

IF  AS=CHRS(27)  THEN  GOTO  25000 

03F4 

0F56 

03F4 

0F56 

GOSUB  9020  'SCAN  SUBROUTINE  -  GET  A  RECORD 

03F9 

0F56 

IF  MIDS(ERRSTAT$,14,3):’’415"  THEN  GOTO  25000 

0415 

0f5A 

0415 

0F5A 

TEXTS: . CLEAR  THE  INPUT  AREA 

041E 

0F5A 

041E 

0F5A 

GOSUB  8000  'DECODE  HEADER 

0'.23 

0F5A 

0423 

0F5A 

GOSUB  8050  'CHECK  FOR  END  OF  JOB/END  OF  BATCH 

0428 

0F5A 

0428 

0F5A 

GOSUB  8200  'DECODE  THE  RESPONSE  POSITIONS 

RACP930 
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042D 

OFSA 

0420 

0F5A 

LITHOS  <  MIDS(TEXTS,22,8) 

043F 

0F5E 

043F 

OF5E 

GOSUB  8070  'CHECK  FOR  SCANNER  ERRORS 

0444 

0F5E 

0444 

0F5E 

GOSUB  8100  'PRINT  THE  DATA  OH  THE  SCREEN 

0449 

0F5E 

0449 

0F5E 

REM  SINCLUOE:  'RACM930.M01 '  INCLUDE  THE  SHORT  FORM  REFORMAT/EDIT  MOO 

0449 

0F5E 

REM 

0449 

0F5E 

REM 

AMBULATORY  CARE  INFORMATION  SYSTEM  11  MAR  87 

***« 

0449 

0F5E 

REM 

0  R  BOLLING 

0449 

0F5E 

REM 

•***  MODULE  NAME  RACM930.MO1 

0449 

OFSE 

REM 

***•  SCANNER  PROGRAM  #  :  930-REPEAT  ENCOUNTER  FORM 

**** 

0449 

0F5E 

REM 

*«** 

0449 

OFSE 

REM 

PURPOSE  :  REFORHAT/EDIT  THE  REPEAT 

0449 

OFSE 

REM 

ENCOUNTER  FORM. 

0449 

OFSE 

REM 

0449 

OFSE 

REM 

*•••  RESERVED  LINE  NUMBERS  100-199 

0449 

OFSE 

REM 

0449 

OFSE 

0449 

OFSE 

N.ERR  <0  'COUNTS  THE  NUMBER  OF  ERRORS 

0450 

0F60 

0450 

0F60 

REM 

LITHO  CODE  DONE  IN  BAS  PROGRAM 

0450 

0F60 

0450 

0F60 

REM 

CLINIC  CODE  ••• 

0450 

0F60 

REM 

...  CLINIC  CODE  WHEN  SINGLE  BUBBLED  ... 

0450 

0F60 

TOO 

IF  MID$<TEXT$,34.2)="  "  THEN  101 

0468 

0F60 

X=VAL(MI0S<TEXT$,34,2)) 

04 7E 

0F62 

CLI.COOS^LIBUBSIX) 

0490 

0F66 

GOTO  106 

0494 

0F66 

0494 

0F66 

REM 

...  CLINIC  COOE  WHEN  HAND  COOED  ... 

0494 

0F66 

101 

IF  MI0$<TEXTS,30,1)="  "  THEN  102 

04AC 

0F66 

IF  MI0$(TEXTS,31,3)=»  «  THEN  102 

04C4 

0F66 

CK . X=VAL  <M I DS( TEXTS , 30 , 1 ) ) 

040A 

Cr68 

CK.COO$=MID$<TEXT$,31,3) 

04EC 

0F6C 

CL1.COOS=CLINIC1.PFX$(CK.X)  ♦  CK.COOS 

0504 

0F6C 

GOTO  106 

0508 

0F6C 

0508 

0F6C 

REM 

GOSUB  5500  'OUTP  UCA  COOE  CHECK 

0508 

0F6C 

REM 

IF  RT.5500  *  0  THEN  GOTO  101 

0508 

0F6C 

102 

N.ERR  :  N.ERR  ♦  1 

0510 

0F6C 

ED.MSG$(N.ERR)="INVALID  OR  MO  CLINIC  COOE" 

0524 

0F6C 

0524 

0F6C 

REM 

PATIENT  SSN  ••• 

0524 

0F6C 

106 

SSNS  »  MI0$(TEXTt,45,9) 

0536 

OF  70 

0536 

OF  70 

REM 

FAMILY  MEMBER  PREF  **• 

0536 

0F70 

108 

FMEMPS=MIDS(TEXTt,54,2) 

0548 

0F74 

0548 

OF  74 

REM 

VISIT  COUNT  *♦• 

0548 

0F74 

110 

VCNTS=''1" 

0551 

OF  78 

XS=M1DS(TEXTS,56,1) 

0563 

0F7C 

IF  XS="1"  THEN  VCNTt="0" 

RACP930 

REPEAT  ENCCXJNTER  DESTRING/OECQOE  PROGRAM 
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OSTA 

0F7C 

IF  XS>“1"  THEN  VCMT$=Xt 

0551 

0f7C 

0591 

0F7C 

REM 

PROVIDER  TIME 

0591 

0670 

112 

X=VAL{MID${TEXT$,57,2)) 

05A7 

0670 

PPROV.TIM$=PROV.TIME$<X) 

05B9 

0680 

15B9 

0680 

REM 

REFERRAL  CODE  •** 

0589 

0680 

CIC.X=VAL(MID$(TEXTt,59, 1 )) 

05CP 

0680 

CK.C00$>HI0S(TEXT$,60,3} 

05E1 

0680 

REM 

IF  CK.XsQ  AND  CK.COOSs"  «  THEN  GOTO  114  ‘MAY  NOT  BE  COC 

05E1 

0680 

REM 

GOSUB  5600  'VALIDATE  INP  UCA  CODE 

0561 

0680 

REM 

IF  RT.S600  >  0  THEN  GOTO  113 

05E1 

0680 

REM 

N.ERR  •  N.ERR  ♦  1 

0561 

0680 

REM 

ED.MSGS<N.ERR}°“«11-12  invalid  referral  CODE" 

0561 

0680 

0561 

0680 

113 

RE6.P6XS»REFER.PFX$(CX.X) 

05  F3 

0684 

REF.COOSxCK.CQOS 

05FC 

0688 

05  fC 

0688 

REM 

PROCEDURE  CODE 

j5FC 

0688 

114 

PROC$sMIO$(TEXT$,63,5) 

0606 

0F8C 

0606 

0f8C 

REM 

•••  DIAGNOSIS  ••• 

0606 

068c 

0606 

0F8C 

116 

X=VAL<MIDS<TEXT$,68,1)) 

C62A 

068C 

IF  X=0  THEN  PRIMDX$="« 

0638 

0690 

IF  X=1  THEN  PRIHOX$*"V" 

064C 

069f, 

IF  Xs2  THEN  PRIMOX$="S" 

0660 

06’'0 

DXTMP*=M IDS<  TEXTS ,69,5) 

0672 

0694 

IF  OXTMPS*"  “  THEN  GOTO  120 

0634 

0694 

0684 

0694 

REM  REMOVE  LEADING  3LANKS 

0684 

0694 

118 

IF  LEFTS(0XTMP$,1)*"  "  THEN  DXTMP$=RIGHT$(DXTMP$,4)+"  ":G0T0 

06B3 

0694 

0683 

0694 

120 

LASTCS=RIGHT$<DXTMPS,1)  'GET  LAST  CHAR 

06C2 

0698 

16  LASTCSo"  «  AND  LASTC$<>''0"  THEN  PRIMOXS*""  ‘REMOVE  V  OR  S 

0666 

0698 

PRIMDXl=LE6T$<PRIMOX$*OXTMP$,5>  ‘GET  5  CHAR  ONL' 

0700 

0698 

0700 

0698 

IF  PRIMOXSo"  "  THEN  121 

0706 

0698 

N.ERR=N.ERR'‘’1 

0716 

0698 

ED.MSG$(N.ERR)="NO  DIAGNOSIS  COOED" 

072A 

0698 

072a 

0698 

121 

REM 

0728 

0698 

VDAT. OFFSET  =  74 

07,2 

069A 

PPFX, OFFSET  s  78 

0739 

069C 

PNUM. OFFSET  *  79 

0740 

069E 

TOT 

■OFFSET  »  9 

0747 

06A0 

POINTER  =  0 

0746 

06A2 

0746 

0FA2 

CM$=MIDS(0ATE$,1,2)  'CURRENT  MONTH 

0760 

06A6 

0760 

06A6 

REM 

LOOP  THROUGH  THE  FOLLOWING  CODE  5  TIMES 

0760 

0FA6 

FOR  1421  =  1  TO  5 

0767 

06A6 

REM 

•**  VISIT  DATE  *** 

0767 

06A6 

YRS=MIDt(DATEt,9,2)  'CURRENT  YEAR 
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0779 

OFAA 

0790 

OFAA 

07A9 

OFAA 

07BE 

OFAA 

07DE 

OFAA 

07EC 

OFAE 

07FE 

0FB2 

0810 

0FB6 

0833 

0FB6 

0856 

0FB6 

0856 

0FB6 

085  F 

OFBA 

0864 

OFBA 

0873 

OFBC 

037B 

OFBC 

0898 

OFBE 

0898 

OFBE 

0898 

OFBE 

08AF 

0FC2 

08C6 

0FC6 

08C6 

0FC6 

08E5 

0FC6 

08E9 

0FC6 

08E9 

0FC6 

0905 

0FC6 

0905 

0FC6 

0906 

0FC6 

0911 

0FC6 

0923 

0FC6 

0924 

0FC6 

0924 

0FC6 

0924 

0FC6 

0924 

0FC6 

0924 

0FC6 

0933 

0FC6 

0945 

0FC6 

0952 

0FC8 

095E 

OFCA 

0974 

OFCA 

0985 

OFCA 

0991 

OFCC 

0998 

OFCC 

0990 

OFCC 

09A1 

OFCC 

09A1 

OFCC 

09A2 

OFCC 

09A2 

OFCC 

09A2 

OFCC 

09A2 

OFCC 

09A2 

OFCC 

09A2 

OFCC 

09A2 

OFCC 

09A2 

OFCC 

09a2 

OFCC 
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X$=HIO$(TEXT$,VDAT.OFFSET+POINTER,4)  'MONTH  AND  DAY  FROM  FORM 
IF  X$°STRINGS(4,"  ")  THEN  GOTO  128 
IF  LEFT$<X$,2)<=CMt  THEN  122  ‘OX,  USE  THIS  YEAR 
YRS''RIGHT$(STR$(VAL(YRS)-1),2)  'USE  LAST  YEAR 

122  VI0ATE$»YR$  ♦  X$ 

D1S=HID$(X$,3,1) 

02$-MI0S<XS,4,1) 

IF  D1$="  "  AND  02t<>"  •'  THEN  123 
IF  01$<>"  "  AHO  02$="  "  THEM  123 
REM  ...  EDIT  VISIT  DATE  ... 

CX.5000$=VIDATE$ 

GOSUB  5000  'DATE  CHECK 

IF  RT. 5000=0  THEN  GOTO  124 

123  N.ERR=N.ERR«^1 

ED.MSG$(N.ERR)=“V1SIT  DATE  ERROR  IN  ITEM  <‘4^STR$(I421) 

REM  CARE  PROVIDER 

124  CPROV.PFX$=MID$(TEXTt,PPFX.OFFSET+POIMTER,1) 

CPROV.NUMS=MID$(TEXTS,PNUM.OFFSET+POINTER,4) 

126  PVOC$(I421)=VIDATE$+CPROV.PFX$+CPROV.NUM$ 

GOTO  130 

128  PVDC$<I421)=STRING$<11,''  ") 

130  REM 

POINTER  =  POINTER  +  TOT. OFFSET 
NEXT  1421 
199  REM 

REM . END  OF  MODULE  RACM930.MO1 . 


IF  N.ERR  =  0  THEN  GOTO  997 
LPRIMT  "LITHO  #  ";LITHO$;"  ...  ERRORS" 

FOR  1997  =  1  TO  N.ERR 
LPRINT  USING  "###  ";I997; 

LPRINT  "==»  '';ED.MSG$(I997) 

NEXT  1997 

LM. COUNT  =  LN. COUNT  ♦  N.ERR  +  1 
CNTRLOPT  =  6 

GOSUB  9010  'REJECT  THE  FORM 

GOTO  998  'BYPASS  THE  DISX  WRITER - 
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1 

09A2 

OFCC 

REM 

09A2 

OFCC 

REM 

RESERVED  LINE  NUMBERS  200-299 

**** 

09A2 

OFCC 

REM 

09A2 

OFCC 

09A2 

OFCC 

REM 

BUILD  THE  OUTPUT  RECORD 

09A2 

OFCC 

09A2 

OFCC 

60SUB  270  ‘BUILD  FIRST  PART  OF 

the  record  key  (RECKEYS) 

09A7 

OFCC 

09A7 

OFCC 

REM 

09A7 

OFCC 

REM 

RECORD  TYPE  "1"  -  MAIN  TRANSACTION  •••• 

09A7 

OFCC 

REM 

09A7 

OFCC 

09A7 

OFCC 

FOR  1412  =  1  TO  5 

09AE 

OFCC 

IF  PV0C$<I412)»STRING$<11,“  “T  THEN 

GOTO  250 

0904 

OFCE 

RECOUTS  ="9301'‘+RECKEY1+PVOCS<I412) 

■BEGIN  KEY  WITH  VISIT  DATE 

09F5 

0FD6 

ISTEP  «  1412 

09FC 

0FD8 

GOSUB  272 

•DO  SECOND  PART  OF  KEY 

0AO1 

0FD8 

GOSUS  274 

■00  TYPE  1  RECORD 

0AO6 

0FD8 

RECOUTS  =REC0UT$+RECKEY2S+RECTYP1$ 

■ADO  TYPE  1  RECORD 

0A19 

OFEO 

GOSUB  280 

■PAD 

0A1E 

OFEO 

PRINT  #1, RECOUTS 

■WRITE  IT 

0A29 

OFEO 

GOSUB  276 

■DO  TYPE  2  RECORD 

0A2E 

OFEO 

GOSUB  280 

'PAD 

0A33 

OFEO 

PRINT  #1, RECOUTS 

■WRITE  IT 

Ca3£ 

OFEO 

250 

NEXT  1412 

0A50 

OFEO 

0A50 

OFEO 

GOTO  299 

0A54 

OFEO 

0A54 

OFEO 

REM 

1  A54 

OFEO 

REM 

SUBROUTINE  270  -  BUILD  THE  RECORD 

KEY  PART  1  **•' 

0A54 

OFEO 

REM 

0A54 

OFEO 

270 

RECXEYS=''" 

0A5D 

OFEO 

0A5D 

OFEO 

REM 

•**  CLINIC  ID  (PREFIX  +  COO)  •»* 

0A50 

OFEO 

RECKEYS=  CL1.PFXS+CL1.C00S 

0A6B 

0FE4 

CA6B 

0FE4 

RETURN 

0A6E 

0FE4 

0A6E 

0FE4 

REM 

•*•  RECORD  XET  PART  2  -CALLED  WITHIN 

LOOP  TO  ALTER  LITHO-  ••• 

0A6E 

0FE4 

0A6E 

0FE4 

272 

RECKEY2S="" 

0A77 

0FE4 

0A77 

0FE4 

REM 

PATIENT  SSH 

0A77 

0FE4 

RECKEY2S  =  SSNS 

0A80 

0FE4 

OASO 

0FE4 

REM 

*»*  FAMILY  MEMBER  PREF  **• 

0A60 

0FE4 

RECXEY2S  =  RECKEY2$  ♦  FMEMPS 

0A8C 

0fE4 

0A8C 

0FE4 

REM 

**•  LIIHO  CODE  »** 

OASC 

0FE4 

RECXEY2S  =  RECKEY2S  +  RIGHTS(STRS( ISTEP), 1 )  +  RIGHTS(LITH0S,7) 

0A81 

0FE4 

OABl 

0FE4 

REM 

•**  FORM  NUMBER 

0A31 

0FE4 

RECXEY2S  =  RECKEY2S  ♦  "93" 

CA30 

0rE4 

IBM  Personal  Conputer  BASIC 


PAGE  10 
07-06-87 
09:25:22 
Con^iiler  VI. 00 


RACP930 

REPEAT  ENCOUNTER  DESTRING/OECOOE  PROGRAM 


Offset  Data  Source  Line 


PACE  11 
0706-87 
09:25:22 

IBM  Personal  Conrxiter  BASIC  Conpiler  VI. CO 


OASO 

0FE4 

RETURN 

OACO 

0FE4 

OACO 

0FE4 

REM 

r**«* 

OACO 

0FE4 

REM 

SUBROUTINE  275  -  BUILD  RECORD  TYPE  1 

**** 

OACO 

0FE4 

REM 

r**«***< 

r*«*« 

OACO 

0FE4 

274 

RECTYPISs'"' 

0AC9 

0FE4 

0AC9 

0FE4 

REM 

VISIT  COUNT  ••• 

0AC9 

0FE4 

RECTYPIS  =  RECTYP1S  +  VCNTS 

OADS 

0FE4 

OAOS 

0FE4 

REM 

*•*  PROV  time 

0A05 

0FE4 

RECTYPIS  =  RECTYPIS  ♦  PPROV.TIMS 

0AE1 

0FE4 

0AE1 

0FE4 

REM 

SPACES  ••• 

0AE1 

0FE4 

RECTYPIS  =  RECTYPIS  ♦  STRINGSCIO,"  ") 

0AF3 

0FE4 

0AF3 

0FE4 

REM 

•**  REFERRAL  CODE  (PREFIX  AND  COO)  **• 

0AF3 

0FE4 

RECTYPIS  «  RECTYPIS  ♦  REF.PFXS  +  REF. COOS 

OB06 

0FE4 

0006 

aFE4 

REM 

•••  SPACES  ••• 

OB06 

0FE4 

RECTYPIS  «  RECTYPIS  ♦  STRINGSdl,"  ") 

0B13 

0FE4 

0B18 

0FE4 

REM 

PATIENT  DIAGNOSIS  (PREFIX  ANO  NUM)  ••• 

0818 

0FE4 

RECTYPIS  *  RECTYPIS  ♦  PRIMOXS 

0824 

0FE4 

0B24 

0FE4 

RETURN 

0827 

OFE4 

0827 

0FE4 

REH 

»«**• 

0827 

0FE4 

REM 

•••  RECORD  TYPE  "2"  •  RECKEY  ♦  PROCEDURE  CODE 

*** 

0827 

0FE4 

REM 

»**** 

0827 

0FE4 

276 

REM 

0828 

0FE4 

0B2S 

0FE4 

RECOUTS  ="9302"+RECKEYS+PVOCS(I412)+RECKEY2S 

'BUILD 

KEY 

084  F 

0fE4 

RECOUTS  =  RECOUTS  ♦  ”1"  ♦  PROCS 

'ADD  PROCEDURE 

0862 

0FE4 

0862 

0FE4 

RETURN 

0865 

0FE4 

0865 

0FE4 

REM 

***«**«******«******'**«*»«*****«*****«******«****4 

r******i 

0B65 

0FE4 

REM 

••••  SUBROUTINE  280  -  PAD  THE  RECORD  TO  HAXLENGTH 

**** 

0865 

0FE4 

REM 

i***«**l 

0865 

0FE4 

280 

PAD=MAXLENGTH  -  LEV(RECOUTS)  'FIND  OUT  HOW  SHORT 

THE  RECORD 

IS 

OB  73 

0FE6 

RECOUTS  =  RECOUTS  +  STRINGS(PAD,PAOS)  'PAD  THE  RECORD  WITH 

FILL 

CHAR 

0886 

0FE6 

RETURN 

0889 

0FE6 

0889 

0FE6 

299  REM 

088A 

0FE6 

088A 

0FE6 

0B8A 

0FE6 

998 

REM  CONTINUE 

0B8B 

0FE6 

088B 

0FE6 

999 

REAOTYPE  =  2 

0B92 

0FE6 

IF  LN. COUNT  >  48  THEN  GOSUB  7100  'PRINTER  HEADING 

0BA2 

0FE6 

GOTO  10 

RACP930 
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0BA6  0FE6  REM  END  OF  SCAN/DECOOE/WRITE  LOOP  ==========.=====*===================== 

0BA6  0FE6 

0BA6  0FE6  1000  REM  SIHCLUDE:  ‘RACS 1000. SUB*  Include  the  VERIFY  LOGON  SUB 

0BA7  0FE6  REM 

0BA7  0FE6  REH  *  NAME:  RACS1000  LOGON  VERIFICATION  SUBROUTINE  * 

0BA7  0FE6  REM  •  Date:  28  Feb  84  PATIENT  REGISTRATION  PROGRAM  * 

0BA7  0FE6  REM 

0BA7  0FE6  REM  PATIENT  OMR  INPUT  PROGRAM  • 

0BA7  0FE6  REM  • 

0BA7  0FE6  REM  This  program  verifies  user  is  logged  on  properly.  If  there  is  no  • 

08A7  0FE6  REM  valid  user  logged  on  at  the  time  of  execution,  this  subroutine  will* 

0SA7  0FE6  REM  chain  to  the  logon  program  RACPOS,  otherwise  a  return  is  issued.  * 

0BA7  0FE6  REM  ••*••••*•••*•*••*•••*••••*•*••••«•*••••••*«»•.»•«»•*»•»****•••»••.»*• 

06A7  0FE6  REM  RESERVED  LINE  NUMBERS  ARE  1001  THRU  1010 

0BA7  0fE6  REM 

0BA7  0FE6  1001  OPEN  "I", 1, "RACL0G.DAT" 

0839  0FE6  IF  EOF(1)  THEN  1002  'MAKE  THEM  LOG  ON  FIRST 

0BC7  0fE6  INPUT  #1 .USERS! 1 ),0T$,TMt,PID* 

OSES  0FF2  IF  USERSCI)  =  THEM  1002  'MAKE  THEM  LOG  ON  FIRST 

0BF6  0FF2  IF  USER$(1)  «  '<*•*•*•>•  THEM  1002  ‘MAKE  THEM  LOG  ON  FIRST 

0C04  0FF2  CLOSE  1 

OCQB  0FF2  SCREEN  0,1, 0,0 

0C21  0FF2  COLOR  FORE, BACK, BORO 


0C37 

0FF2 

CLS 

oc3a 

0FF2 

RETURN 

0C3E 

0FF2 

’C3E 

0FF2 

1002  CLOSE 

0C42 

0FF2 

CHAIN  "RACP05" 

1  ■■  ■ 

0C49 

0FF2 

0C49 

0FF2 

2000 

REM  SINCLUOE:  'RACS2000.SU8' 

Include  the  REPLY/DELAY  SUB 

0C4A 

0FF2 

REM 

****4 

***** 

0C4A 

0FF2 

REH 

*«*« 

AMBULATORY  CARE  DATA 

BASE  13  APR  85 

•  *** 

0C4A 

0FF2 

REH 

SKIP  COLE 

**** 

0C4A 

0FF2 

REH 

SUBROUTINE  NAME 

:  RACS2000.SUB 

***• 

0C4A 

0FF2 

REH 

sk«** 

SCANNER  PROGRAM  # 

:  ALL 

***« 

0C4A 

0FF2 

REH 

**** 

FUNCTION 

:  THIS  SUBROUTINE  MODULE 

**** 

0l4A 

0FF2 

REM 

**** 

SERVERS  AS  A  WAIT  AND  REPLY 

**** 

0C4A 

0FF2 

REM 

ENTRY  MODULE 

**** 

OCAA 

0FF2 

REM 

***• 

INPUT 

SINGLE  KEYBOARD  ENTRY 

**** 

0C4A 

OFFZ 

REM 

**** 

0C4A 

0FF2 

REH 

OUTPUT 

:  KEYBOARD  ENTRY  ■  UPPER  CASE 

**** 

0C4A 

0FF2 

REM 

**** 

**** 

0C4A 

0FF2 

REM 

RESERVED  LINE 

**** 

0C4A 

0FF2 

REN 

**** 

NUMBERS 

:  2001-2010 

**** 

0C4A 

0FF2 

REM 

***** 

0C4A 

0fF2 

2001 

REM  REPLY  FUNCTION 

0C4B 

0FF2 

2002 

REPLYS=INKEYS  :  IF  REPLYS="'* 

THEN  2002 

0C5F 

0FF6 

REPLY=ASC(REPLYS) 

0C6'  OFFS  IF  REPLY  >  90  THEN  REPLY$=CHR$(REPLY  XOR  32)  'CONVERT  TO  CAPS 

0C84  OFFS  IF  REPLYt  <  "A"  OR  REPLYS  >  "Z"  THEN  REPLYS="?" 

OCBO  0FF8  RETURN 

0CB3  OFFS 

0C83  OFFS  5000  REM  SINCLUOE;  ' RACSSOOO.SUB*  Include  the  DATE  EDITOR  SUB 
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0CS4 

OFFS 

REH 

0CB4 

OFFS 

REM 

•«** 

AMBULATORY  CARE  DATA  BASE  13  APR  85 

**** 

0CB4 

OFFS 

REM 

SKIP  COLE 

•*** 

0CB4 

0FF8 

REH 

*«*« 

SUBROUTINE  NAME  :  RXXS5000.SUS 

*•** 

0CB4 

OFFS 

REH 

*•** 

SCANNER  PROGRAM  »  :  ALL 

0CB4 

0FF8 

REH 

*«•* 

FUNCTION  :  THIS  SUBROUTINE  MODULE 

0CB4 

OFFS 

REH 

PERFORMS  A  DATE  EDIT 

**** 

0CB4 

0FF8 

REM 

*««• 

**«• 

0CB4 

OFFa 

REN 

**** 

INPUT  :  DATE  TO  BE  CHECKED  MUST  BE 

**•* 

0CB4 

0FF8 

REM 

««** 

IN  THE  variable  NAMED 

**** 

0CB4 

OFFS 

REM 

•CK.5000$> 

***• 

0CB4 

OFFS 

REH 

***♦ 

IN  THE  FORMAT  "YYMMOD" 

**** 

0CB4 

OFFS 

REM 

***« 

0CB4 

OFFS 

REM 

***• 

OUTPUT  :  •RT.5000'  IS  THE  RETURN  CODE 

**•* 

0CB4 

OFFS 

REM 

•**« 

VARIABLE.  IF  THIS  VARIABLE 

0CB4 

OFFS 

REM 

**** 

CONTAINS  ANY  NUMBER  OTHER 

•  ••• 

0CB4 

OFFS 

REH 

**** 

THAN  0.  AN  ERROR  WAS  FOUND 

0CB4 

OFFS 

REM 

**«• 

IN  THE  DATE. 

*•** 

0C84 

OFFS 

REH 

**•* 

0CS4 

OFFS 

REM 

•«** 

RESERVED  LINE 

*««* 

0CB4 

OFFS 

REM 

*«•* 

NUMBERS  :  5001-5009 

0CB4 

OFFS 

REM 

0CB4 

OFFS 

RT 

5000  =  0 

ocsa 

OFFS 

CKYEAR  =  VAL<LEFT$(CK.5000$,2))  'YEAR  NUMERIC  VALUE 

OCCE 

OFFA 

CKMONTH  *  VAL(HID$<CK.SOOO$,3,2))  'MONTH  NUMERIC  VALUE 

0CE4 

OFFC 

CKDAY  =  VAL(RIGHT$(CK,5000S,2))  'DAY  NUMERIC  VALUE 

0CF7 

OFFE 

0CF7 

OFFE 

IF  CKMONTH  <  1  THEN  RT. 5000=1  :  GOTO  5009 

0000 

OFFE 

IF  CKMONTH  >  12  THEN  RT. 5000=1  :  GOTO  5009 

0023 

OFFE 

IF  CKDAY  <  1  THEN  RT. 5000=2  :  GOTO  5009 

0039 

OFFE 

IF  CKDAY  >  31  THEN  RT. 5000=2  :  GOTO  5009 

0C4F 

OFFE 

004  F 

OFFE 

REM 

LEAP  YEAR  CHECK 

004  F 

OFFE 

M0LENGTH{2)  =  23 

0056 

OFFE 

IF  CKMONTHo  2  THEN  GOTO  5005  'MUST  BE  FEBRUARY 

0065 

OFFE 

IF  (CKYEAR  MOO  4)  <>  0  THEN  GOTO  5005  'MUST  BE  A  LEAP  YEAR 

00 7A 

OFFE 

M0LENGTH(2)  =  29 

0031 

OFFE 

0081 

OFFE 

5005 

IF  CKDAY  >  MOLENGTHfCKMONTH)  THEN  RT. 5000=3  :  GOTO  5009 

OOAO 

OFFE 

OOAO 

OFFE 

5009 

RETURN 

OOA3 

OFFE 

00  A3 

OFFE 

-  ... 

00A3 

OFFE 

00A3 

OFFE 

5010 

REM  SINCLUDE:  'RACS5010.SUB'  Include  the  NUMERIC  STRiNG  EDITOR 

OOA4 

OFFE 

REM 

•****« 

0CA4 

OFFE 

REM 

**** 

AMBULATORY  CARE  DATA  BASE  1  MAY  85 

00A4 

OFFE 

REM 

SKIP  COLE 

00  A4 

OFFE 

REM 

SUBROUTINE  NAME  :  RXXSSOIO.SUB 

**** 

OOA4 

OFFE 

REM 

SCANNER  PROGRAM  »  ;  ALL 

**•* 

00  A4 

OFFE 

REM 

FUNCTION  :  THIS  SUBROUTINE  MODULE 

0DA4 

OFFE 

REM 

•  **« 

PERFORMS  A  NUMERIC  STRING 

**** 

00A4 

OFFE 

REM 

EDIT. 

OOA4 

OFFE 

REM 

**** 

RACP930 
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OOA4 

OFFE 

REM 

**** 

INPUT  : 

STRING  TO  BE  EDITED  IS  IN 

**** 

OOA4 

OFFE 

REM 

»*** 

THE  VARIABLE  NAMED 

**** 

00A4 

OFFE 

REM 

•CK.5010$' 

***« 

OOA4 

OFFE 

REM 

***• 

0DA4 

OFFE 

REM 

***« 

OUTPUT  : 

•RT.5010*  IS  THE  RETURN  CODE 

*«** 

0DA4 

OFFE 

REM 

VARIABLE.  IF  THIS  VARIABLE 

0DA4 

OFFE 

REM 

CONTAINS  ANY  NUMBER  OTHER 

**•* 

00  A4 

OFFE 

REM 

THAN  0,  AN  ERROR  UAS  FOUND 

*•** 

0DA4 

OFFE 

REM 

IN  THE  STRING. 

**** 

0DA4 

OFFE 

REM 

«*»* 

OOA4 

OrrE 

REM 

RESERVED  LINE 

***« 

Q0A4 

OFFE 

REM 

**«» 

NUMBERS  : 

5011-5019 

*•** 

0DA4 

OFFE 

REM 

0DA4 

OFFE 

RT.5010  =•  0 

ODAB 

1000 

00A3 

1000 

FOR  15010  =  1  TO  LEN(CIC.5010$) 

OOBB 

1006 

05010-  ASC(MI0S(CIC.S010$, 

15010,1)) 

OOCf 

100A 

IF  J5010  <  48  OR  J5010  > 

57  THEN  RT.5010  =  RT.5010  ♦  1 

OOF7 

100A 

NEXT 

15010 

OE08 

100A 

0E03 

100A 

RETURN 

0E03 

100A 

0E08 

lOOA 

5500 

REM 

INCLUDE:  'RACS5500.SUB' 

Include  the  OUTPATIENT  UCA  CHECK 

SUB 

OEO: 

100A 

5600 

REM 

INCLUDE:  •RACS5600.SUB' 

Include  the  INPATIENT  UCA  CHECK 

SUB 

OEOO 

100A 

OEOD 

100A 

7000 

REM  $  INCLUDE:  •RACS7000.SUB' 

Include  the  SCREEN  HEADER  SUB 

OEOE 

100A 

REM 

«**«•««****»*«**«»«***«**•****«*«**••**««**«•*«*•«***«*****•*•*«««* 

CEDE 

100A 

REM 

**«* 

AMBULATORY  CARE  DATA 

BASE  13  APR  85 

**«• 

OEOE 

100A 

REM 

SKIP  COLE 

*«** 

OEOE 

100A 

REM 

**** 

SUBROUTINE  NAME 

RACS7000.SUB 

OEOE 

1C0A 

REM 

««** 

SCANNER  PROGRAM  # 

all 

***« 

OEOE 

1CCA 

REM 

FUNCTION 

THIS  SUBROUTINE  MODULE 

**«* 

OEOE 

lOOA 

REM 

PRINTS  THE  STANDARD  SCREEN 

**«’* 

OEOE 

100A 

REM 

**** 

HEADING. 

•  »*« 

OEOE 

lOOA 

REM 

**** 

INPUT 

COMMON  VARIABLE  USERS(2) 

*»** 

OEOE 

100A 

REM 

SrsTEM  DATE 

***• 

OECE 

100A 

REM 

*««« 

**** 

OEOE 

100A 

REM 

OUTPUT 

SCREEN  HEADING 

**«* 

OEOE 

lOOA 

REM 

**** 

***• 

OEOE 

100A 

REM 

**** 

RESERVED  LINE 

**** 

OEOE 

100A 

REM 

***« 

NUMBERS 

7001-7010 

**«* 

r;0E 

100A 

REM 

**«*• 

OEOE 

100A 

OEOE 

100A 

7001 

LOCATE 

1,1 

0E18 

100A 

PRINT 

"U.S.  ARMY  AMBULATORY  CARE  INFORMATION  SYSTEM" 

0E20 

lOOA 

LOCATE 

1,65 

0E20 

100A 

PRINT 

DATES; 

0035 

100A 

LOCATE 

2,1 

CE42 

lOCA 

PRINT 

"USER  :  ";USERS(1) 

OEiF 

ICOA 

RETURN 

0E52 

100A 

7100 

REM  tINCLUOE:  'RACS7100.SU8' 

Include  the  PRINTER  HEADER  SUB 

OF  5  3 

ICOA 

REM 

**** 

AMBULATORY  CARE  DATA 

BASE  13  APR  85 

**** 

0C:3 

ICOA 

REM 

*«** 

SiriP  COLE 

**** 

RACP930 
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0E53 

100A 

REM 

**** 

SUBROUTINE  NAME 

RXXS7100.SUB 

**** 

0E53 

100A 

REM 

**«* 

SCANNER  PROGRAM  » 

ALL 

**•* 

0E53 

100A 

REM 

**** 

FUNCTION 

THIS  SUBROUTINE  MODULE 

**«* 

0ES3 

100A 

REM 

*«** 

PRINTS  THE  STANDARD  HEADING 

**«* 

0ES3 

100A 

REM 

**** 

ON  THE  PRINTER. 

**** 

0ES3 

100A 

REM 

**** 

INPUT 

DATE , PAGE. PGM IDS, PGMT I TLS 

•*•* 

0ES3 

100A 

REM 

**** 

**** 

0ES3 

100A 

REM 

**** 

OUTPUT 

PRINTER  HEADING,  LN. COUNT 

**** 

0ES3 

100A 

REM 

«*** 

**** 

0ES3 

100A 

REM 

RESERVED  LINE 

**•* 

0E53 

100A 

REM 

***« 

NUMBERS 

7101-7110 

•*** 

0ES3 

100A 

REM 

***** 

0ES3 

100A 

0E53 

100  A 

7101 

IF  PAGE  >  0  THEN  LPRINT  CHRS(12}: 

0E69 

100  A 

LPRINT 

“ARMY  AMBULATORY  CARE  INFORMATION  SYSTEM _  “;PGMTITL$; 

0E76 

10QA 

LPRINT 

TAB(70);DATES 

0ES9 

100A 

PAGE^PAGE^-I 

0E91 

100A 

LPRINT 

“PROGR AM  “ ; PGM 1 01 ; T AB  <  70 ) ; "P AGE “ ; 

OEAE 

100A 

LPRINT 

USING  “«###«; PAGE 

OEBA 

1Q0A 

LPRINT 

0EC2 

100  A 

LN.CaUNT*3 

0EC9 

100A 

RETURN 

OECC 

100A 

OECC 

100A 

8000 

REM  SINCLUOE:  ' RACS8000 . SUB ■ 

Include  the  DECODE  SUB  CROUP 

OECD 

100A 

REM 

OECD 

100A 

REM 

*«*« 

AMBULATORY  CARE  DATA 

BASE  13  APR  85 

*** 

OECD 

100A 

REM 

SKIP  COLE 

**• 

OECD 

100A 

REM 

SUBROUTINE  NAME 

RXXS8000.SUB 

*** 

OECD 

100A 

REM 

**** 

SCANNER  PROGRAM  # 

ALL 

*** 

OECD 

100A 

REM 

*««« 

FUNCTION 

THIS  SUBROUTINE  MODULE 

*** 

OECD 

100A 

REM 

**** 

IS  A  GROUPING  THAT  PERFORMS 

*** 

OECD 

100A 

REM 

«•«* 

VARIOUS  DECODING  FUNCTIONS 

*** 

OECD 

100A 

REN 

•  **« 

ON  THE  SCANNER  DATA 

**• 

OECD 

100A 

REM 

*«** 

*** 

OECD 

100A 

REN 

8001  -  DECODE  THE 

HEADER  POSITIONS  (POINTER  0-20) 

*** 

OECD 

100A 

REM 

***« 

8050  -  CHECK  FOR  END  OF  JOB 

*** 

OECD 

100A 

REM 

*«** 

8100  -  PRINT  THE  HEADER  DATA  ON  THE  SCREEN 

*** 

OECD 

100A 

REM 

**** 

8200  -  DECODE  THE 

RESPONSE  POSITIONS  (POINTER  21-.. 

)  ••• 

OECD 

100A 

REM 

(RETURNED  IN  TEXTS  STRING  VARIABLE) 

*** 

OECD 

100A 

REM 

**«* 

*** 

OECD 

100A 

REM 

**•* 

INPUT 

SHEET  RECORD,  RECORD  LENGTH 

*** 

OECD 

100A 

REM 

**** 

*** 

OECD 

100A 

REN 

**** 

OUTPUT 

•TEXTS’  TRING  VARIABLE 

*** 

OECD 

100A 

REM 

*««• 

•** 

OECD 

100A 

REM 

RESERVED  LINE 

*** 

OECD 

100A 

REM 

*•** 

NUMBERS 

8001-8500 

*** 

OECD 

100A 

REM 

***** 

OECD 

100A 

OECD 

100A 

■DECODE  THE 

HEADER  ONLY 

OECD 

100A 

8001 

POINTER  :  0 

0ED4 

100A 

RECORDPTR  =  VARPTR(SHEETREC(0) ) 

OEDB 

100C 

FOR  J8000  =  1  TO  21 

0EE2 

100C 

8002 

TEXTSs  TEXT$+CHR$<PEEK(RECORDPTR  ♦  POINTER)) 

OFOO 

100C 

P0INTER=P0INTER*1 

RACP930 
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UF4A 
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OFCD 
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.085 
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1110 
.110 
1113 
1113 
1113 
1113 


PAGE  16 
07-06-87 
09:25:22 

Data  Source  Line  IBM  Personal  Conputer  BASIC  Con^iiler  V1.00 


100C 

100E 

1012 

1016 

101A 

101E 

1022 

1026 

102A 

102E 

1032 

1032 

1032 

1032 

1032 

1032 

1032 

1032 

1032 

1032 

1032 

1032 

1032 

1032 

1032 

1032 

1032 

1032 

1032 

1032 

1034 

1034 

1034 

1034 

1034 

1034 

1034 

1034 

1034 

1034 

1034 

1034 

1034 

1034 

1034 

1036 

1036 

1036 

1036 

1036 

1036 

1036 

1036 

1036 


NEXT  J8000 

PROGRAMS^  LEFTS(TEXTS,3) 

BATCHS>  MI0$(TEXTS,4,3) 

SERIALS*  MID$(TEXT1,7,4) 

RUNIOS*  HIDS(TEXTS,11,1) 

FORMS*  MI0S(TEXTS,12,2) 

POCKETS*  MIDS<TEXTS,14,1) 
SCANERR1S*MtO$(TEXTS,16,2) 
SCANERR2S*MIDS(TEXTS, 18,2) 

SCANERR3S=M I DS( TEXTS , 20 , 2 ) 

GOTO  8500 

8050  REM  CHECK  FOR  END  OF  JOB/ENO  OF  BATCH 

IF  PROGRAMS  *  PGMIOS  THEN  GOTO  8500 
LPRINT  STRINGS<80,“*") 

LPRINT 

LPRINT  XRECOROS  PROCESSED  ...  ".‘SERIALS 


LPRINT  "STARTED  AT  .  ";BT1MES 

LPRINT  "ENDED  AT  . ".‘TIMES 

LPRINT  CHRS<12) 

GOTO  30000 


8070  REN  CHECK  FOR  SCANNER  ERRORS 

IF  POCKETS  *  "  "  GOTO  8500 
LPRINT  LITHOS; 

LPRINT  "  ...  SCANNER  ERRORS  !  "; 

LPRINT  SCANERR1S;"  / 

LPRINT  SCANERR2$,‘"  / 

LPRINT  SCANERR3S 

LN=LN+1 

GOTO  999 

8100  REM  PRINT  THE  HEADER  VARIABLES  ON  THE  TUBE.... 

LOCATE  S,1:PRINT  "PROGRAM  ";PROGRAM$; 

PRINT  "  BATCH  “.‘BATCHS; 

PRINT  "  RUN  ".‘RUNIOS; 

PRINT  "  FORM  “.‘FORMS; 

PRINT  "  POCKET  ".‘POCKETS 

GOTO  8500 

8200  REM  DECODE  THE  RESPONSE  POSITIONS 
POINTER  =  21 

RECORDPTR  =  VARPTR<SHEETREC(0)) 

FOR  J8000  *  22  TO  RECOROLENGTH 
8202  TEXTS  *  TEXT$<-CHR$<PEEK(RECORDPTR  ♦  POINTER)) 

POIMTER=POINTER+1 
NEXT  J8000 

8500  RETURN 

REM . END  OF  RXXS8000.SUB  . 

9000  REM  SINCLUDE:  'RACS9000.SUB'  INCLUDE  THE  SCANNER  CONTROL  SUB 
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1114 

1036 

REM 

^**** 

1114 

1036 

REM 

***•  AMBULATORY  CARE  DATA  BASE  13  APR  85 

*«*• 

1114 

1036 

REM 

**«■* 

SKIP  COLE 

«*** 

1114 

1036 

REM 

PROGRAM  NAME 

:  RACS9000.SUB 

1114 

1036 

REM 

**•*  SCANNER  PROGRAM  # 

:  ALL 

•ft*** 

1114 

1036 

REM 

FUNCTION 

THIS  SUBROUTINE  MODULE 

**** 

1114 

1036 

REM 

**** 

CONTROLS  THE  SCANNER  I/O 

**** 

1114 

1036 

REM 

**** 

1114 

1036 

REM 

IMPUT/OUTPUT 

:  REFER  TO  THE  ASYNCHRONOUS 

**•* 

1114 

1036 

REM 

**«« 

COMMUNICATIONS  MANUAL  AND  THE 

**** 

1114 

1036 

REM 

*•** 

PRE-RELEASEO  SOFTWARE  GUIDE 

**** 

1114 

1036 

REM 

***■* 

**** 

1114 

1036 

REM 

1114 

1036 

REM 

*•**  RESERVED  LINE 

**** 

1114 

1036 

REM 

••••  NUMBERS 

;  9001-9100 

•*** 

1114 

1036 

REM 

1114 

1036 

1114 

1036 

1114 

1036 

REN 

1114 

1036 

REM 

SUBROUTINE  9001  •  PROTOCOL  SETUP  FOR  SCANNER 

1114 

1036 

REN 

ARGUMENTS:  PRESET  ... 

SEE  BELOU 

1114 

1036 

REM 

***** 

1114 

1036 

9001 

REM 

1115 

1036 

PROTOCOL(O)  *  9600 

•BAUD  RATE 

me 

1036 

PROTOCOLd)  *  78 

'PARITY  (SEE  PACE  4-8  OF  MANUAL) 

1123 

1036 

PROTOCOL (2)  =  8 

•DATA  BITS 

112A 

1036 

PROTOCOL (3)  =  1 

■STOP  BITS 

1131 

1036 

PROTOCOL<4)  =  2 

•RS-232  PORT 

1138 

1036 

PROTOCOL (5)  =  0 

•WRITE  TIME-OUT 

113F 

1036 

PROTOCOL (6)  =  0 

•READ  TIME-OUT 

1146 

1036 

1146 

1036 

ERRSTATS  -  SPACES(60) 

1152 

1036 

ARGPTR  =  VARPTR(PROTOCOL(0)) 

1159 

1038 

CALL  SETUP  (ARGPTR, ERRSTATS) 

116A 

1038 

ERRMSGS^"" 

1173 

1038 

IF  ASCCERRSTATS)  <>  64  THEN  ERRMSG$*''SETUP  ERROR  "♦ERRSTATS 

118F 

1038 

GOTO  9100 

1193 

1038 

1193 

1038 

REM 

1193 

1038 

REM 

••••  SUBROUTINE  9010  -  CONTROL  OPTIONS  FOR  SCANNER 

1193 

1038 

REN 

ARGUMENTS:  CNTRLOPT 

1193 

1038 

REM 

•••*  CNTRLOPT  =  1  »  START 

SCANNER  (SI) 

1193 

1038 

REM 

CNTRLOPT  =  2  =  STOP 

SCANNER  (SO) 

1193 

1038 

REM 

CNTRLOPT  »  3  *  TERMINATE  COMMUNICATIONS  TO  SCANNER  (DC3) 

1193 

1038 

REM 

****  CNTRLOPT  =  4  s  CLEAR 

TRANSPORT  PATH  (DC2) 

1193 

1038 

REM 

CNTRLOPT  »  5  »  SELECT 

PRIMARY  STACKER  "SI" 

1193 

1038 

REN 

••••  CNTRLOPT  s  6  »  SELECT 

SECONDARY  STACKER  ••32" 

1193 

1038 

REM 

CNTRLOPT  =  7  =  POSITIVE  RESPONSE/SELECT  SCANNER  (0C1) 

1193 

1038 

REM 

CNTRLOPT  =  8  =  REQUEST  STATUS  (ESC) 

1193 

1038 

RtH 

1193 

1038 

9010 

REM 

1194 

1038 

ERRSTATS  =  SPACES{60) 

11A0 

1038 

CALL  CNTROL  (CNTRLOPT, ERRSTATS) 

11B1 

1038 

ERRMSGS="" 

RACP930 

REPEAT  ENCOUNTER  OESTRING/DECOOE  PROGRAM 
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11BA 

1038 

IF  ASC(ERRSTAT$)  <>  64  THEN  ERRMSCS=“CC»ITROL  ERROR  "♦ERRSTATS 

1106 

1038 

GOTO  9100 

110A 

1038 

11DA 

1038 

REH 

****** 

11DA 

1038 

REM 

****  SUBROUTINE  9020  -  SCAN  SHEET  CALL 

***** 

11DA 

1038 

REH 

*«*« 

***** 

IlDA 

1038 

REM 

•••*  ARGUMENTS:  READTYPE 

***** 

11DA 

1038 

REH 

READTYPE  »  2  =  REQUEST  NEU  DOCUMENT  FROM  SCANNER 

***** 

11DA 

1038 

REH 

•**»  READTYPE  =  3  *  RETRANSMIT  CURRENT  DOCUMENT 

***** 

11DA 

1038 

REM 

***« 

***** 

110A 

1033 

REM 

ARGUMENTS;  RECOROLENCTH 

***** 

noA 

1038 

REH 

NUMERIC  VARIABLE  SET  TO  THE  NUMBER  OF  CHARACTERS  TO  BE 

***** 

11DA 

1038 

REH 

*•**  TRANSMITTED 

***** 

11DA 

1038 

REH 

****** 

11DA 

1038 

9020 

REN 

11DB 

1038 

ERRSTATS  >  SPACES(60) 

11E7 

1038 

RECOROPTR  °  VARPTR(SHEETREC(0)) 

11EE 

1038 

CALL  SCAN  (READTYPE, RECORDLEHGTH.RECORDPTR, ERRSTATS) 

'207 

1038 

ERRMSGS=“" 

1210 

1038 

IF  MID$(ERRSTAT$,14,3)  »  “415"  THEN  ERRMSG$«’'ESC" 

1231 

1038 

GOTO  9100 

1235 

1038 

1235 

1038 

REM 

****** 

1235 

1038 

REM 

SUBROUTINE  9030  -  TRANSPORT  PRINT  CALL 

1235 

1038 

REM 

***« 

***** 

1235 

1038 

REH 

••••  ARGUMENTS;  PRINTPOS 

1235 

1038 

REH 

NUMERIC  VARIABLE  INDICATING  THE  STARTING  PRINT  POSITION 

***** 

1235 

1038 

REH 

*•••  VALUES  =  0  THRU  90 

***** 

1235 

1038 

REH 

***# 

***** 

1235 

1038 

REM 

ARGUMENTS:  PSTRINGS 

'•>35 

1038 

REM 

••••  TEXT  TO  BE  PRINTED  ON  THE  FORM 

1235 

1038 

REM 

***« 

1235 

1038 

REM 

NOTE:  THIS  ROUTINE  HAS  NO  EFFECT  UNLESS  THE  SCAN 

***** 

1235 

1038 

REH 

HEADER  SHEET  IS  HARKED  'PRINTER  ON' 

1235 

1038 

REM 

1235 

1038 

9030 

REM 

1236 

1038 

ERRSTATS  »  SPACES{60) 

1242 

1038 

RECOROPTR  =  VARPTR(SHEETREC{0)) 

1249 

1038 

CALL  TPRINTCPRINTPOS, PSTRINGS, ERRSTATS) 

125E 

103E 

IF  ASCCERRSTATS)  <>  64  THEN  ERRMSGS="PRINT  ERROR  "♦ERRSTATS 

127A 

103E 

GOTO  9100 

127E 

103E 

12’E 

103E 

9100 

RETURN 

1281 

103E 

REM  -- 

. END  OF  SUBROUTINE  RACS9000.SUB  . 

1281 

103E 

1281 

103E 

REM 

END  Of  SUBROUTINES  =================*====================:==== 

1281 

103E 

1281 

103E 

25000 

REM  USER  TERMINATED  INPUT...  FILE  IS  MOT  TO  BE  USE0f!!H 

1282 

103E 

LPRINT  "USER  TERMINATED  INPUT  ..  DATA  UILL  NOT  BE  USED!" 

128A 

103E 

LPRINT  "ERASING  FILE  ";0ATFILS 

1297 

103E 

BEEP 

129B 

103E 

CLS  :  PRINT  "USER  TERHINDATED  INPUT  ..  DATA  UILL  NOT  BE  USED! 

M 

12A7 

103E 

CLOSE 

12AB 

103E 

OPEN  OATFILS  FOR  OUTPUT  AS  #1 

RACP930 

RePCAT  ENCOUNTER  OESTRING/OECOOE  PROGRAM 


Offset 

Oata 

Source  Line 

12BO 

103E 

PRINT  #1 , STR I NGSIRECOROLENGTH , "X" ) 

■VOIO  THE  FIRST  RECORD 

12CF 

103E 

CLOSE 

1203 

103E 

1203 

103E 

30000  REM 

1204 

103E 

CLOSE 

1208 

103E 

CHAIN  "RACPIO" 

120F 

103E 

12E2 

103E 

22151 

Bytes  Available 

17154  Bytes  Free 
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0  Warning  Error(s) 
0  Severe  Error(s) 


07-06-87 

1S;07,-19 

Offset  Data  Source  Line  IBM  Personal  Computei  BASIC  Cuif<ilei  V1.00 

001 A  0002  REM  $L1 RESIZE:  132 

001A  0002  REM  SPAGESIZE:  66 

001 A  0002  REM  STITLE:  •RACP940  ■ 

001A  0002  REM  SSUBTITLE:  'SHORT  FORM' 

001A  0002  REM  SPACE 


RACP940 
SHORT  FORM 


Offset 

Data 

Sour 

001A 

0002 

REM 

001A 

0002 

REM 

001A 

0002 

REM 

001A 

0002 

REM 

001A 

0002 

REM 

001A 

0002 

REM 

001A 

0002 

REM 

001A 

0002 

REM 

001A 

0002 

REM 

001A 

0002 

REM 

001A 

0002 

REM 

001A 

0002 

REM 

001A 

0002 

REM 

001A 

0002 

REM 

001A 

0002 

REM 

001A 

0002 

REM 

001A 

0002 

REM 

001A 

0002 

REN 

001A 

0002 

REM 

001A 

0002 

REM 

001 A 

0002 

REM 

001A 

0002 

REM 

001A 

0002 

REM 

001 A 

0002 

REM 

001A 

0002 

REM 

001A 

0002 

001A 

0002 

REM 

001A 

0002 

001A 

0002 

I* 

001A 

0002 

I* 

001A 

0002 

OOTA 

0002 

1 

001A 

0002 

1 

001A 

0002 

1 

001A 

0002 

001A 

0002 

001A 

0002 

001A 

0002 

001A 

0002 

001A 

0002 

001 A 

0002 

001A 

0002 

001A 

0002 

001A 

0002 

001A 

0002 

001A 

0002 

001A 

0002 

REH 

001A 

0002 

001A 

0002 

001A 

0002 

001A 

0002 

001A 

0002 

001A 

0002 

001A 

0002 

PACE  2 
07-06-87 
15:07:19 

IBM  Personal  Computer  BASIC  CoitpUer  VI. 00 


D  R  BOLLING 


AMBULATORY  CARE  INFORMATION  SYSTEM 


SHORT  FORM 


SHORT  FORM  INPUT  PROGRAM 

This  program  reads  the  SHORT  form  OMR  data,  converts  various 
fields,  prints  an  error  report  and  produces  the  file: 

VISIT.OAT 

for  input  to  FOCUS.  NOTE  THAT  THIS  FILE  IS  OPENED  FOR  APPEND 
each  time  the  program  is  run.  Thus,  if  the  file  does  not  exist, 
records  will  be  added  to  the  front.  If  the  file  exists,  records 
will  be  added  to  the  end  of  the  current  file,  ft  is  intended  that 
the  FOCUS  DIALOGUE  MANAGER  ROUTINE  which  loads  the  data  will  delete 
the  data  file  after  the  load  has  been  successfully  accomplished. 

If  there  is  no  valid  user  logged  at  the  time  of  execution,  this 
program  will  chain  to  the  logon  program  RXXPOS,  otherwise, 
the  program  chains  to  program  RXXP10  on  exit. 


SINCLUOE:  'RACOIM.NOO' 


REM  INCLUDE  THE  DIMENSION  DEFINITIONS 


NAME:  RACDIM.MOO  DIMENSION  DEFINITIONS 

Date:  28  Feb  84  Written  by:  Floyd  Cole 

•**«*•*«••*«**««**««««•#*««**«***«**«*«*«««**««•*«**•«*«***'•***«« 

Dimensioned  variables  are  defined  in  this  file. 

It  is  an  included  file  so  it  cannot  be  run  in  a  stand-alone, 
mode. 

This  program  segment  may  be  modified,  but  all  files  containing 
an  include  for  this  segment  must  be  re-compiled  in  order  to 
affect  the  changes  made  here. 

•*•*•*•••••*  START  OF  DIMENSION  DEFINITION  ••**•••••***••**•••* 

DEFINT  A-Z 

DIM  USERS(2),HOLENGTH(12),DATEERR$(3} 

••••••••••••  emD  of  DIMENSION  DEFINITIONS  ••••*••••*•••••••••• 

DIMENSION  STATEMENTS  UNIQUE  TO  THIS  PROGRAM . 


DIM  SHEETREC(1750) 

DIM  PROTOCOL(7) 

DIM  ED.MSGS(30) 

DIM  CLINIC1.PFX$(5) 
DIM  PROVIDER. TIMES(9) 
DIM  PROCED$(16) 


■(MAX.  SIZE  FOR  A  SHEET  FROM  THE  SCANNER) 
'(ARRAY  FOR  SERIAL  BOARD  SETUP  PARAMETERS) 
•(ERROR  MESSAGES  FROM  EDIT  ROUTINES) 
■(PREFIX  -B  D  F  G  S-  FOR  CLINIC  #1) 
■(TIME  TABLE  FOR  PROVIDERS) 

■(PROCEDURE  TABLE  FOR  SHORT  FORM) 


RACP940 
SHORT  FORM 


Offset 

001A 

OOU 

001A 

OOU 

OOU 

OOU 

OOU 

OOU 

OOU 

OOU 

OOU 

OOU 

JOU 

OOU 

OOU 

OOU 

OOU 

OOU 

OOU 

OOU 

OOU 

OOU 

OOU 

OOU 

OOU 

OOU 

OOU 

OOU 

OOU 

OOU 

OOU 

cou 

OOU 

OOU 

OOU 

OOU 

OOU 

OOU 

OOU 

OOtA 

OOU 

OOU 

OOU 

OOU 

OOU 

OOU 

OOU 

0049 

0050 

00'  r 

005E 

0065 

005C 

0078 
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0002 

0002 

0002 

0002 

0002 

0002 

0002 

0002 

0002 

0002 

0002 

0002 

0002 

0002 

0002 

0002 

0002 

0002 

0002 

0002 

0002 

0002 

0002 

0002 

0002 

0002 

0002 

0002 

0002 

0002 

0002 

0002 

0002 

0002 

0002 

0002 

0002 

0002 

0002 

0002 

0002 

0002 

0002 

0002 

0002 

0002 

0002 

1100 

1100 

1102 

1102 

1102 

1102 

1102 


DIM  PTIOS(S) 

DIM  PTIMS(5) 

DIM  TOT.PROC(S) 
DIM  GRaUPS(5,16) 
DIM  SPE.CODSfS) 
DIM  H0LDS(16) 


'(PATIENT  SSM«FI«>) 

■(PATIENT  TIME) 

■(PROCEDURE  total  PER  PATIENT) 
■(PATIENT/PROCEDURE  GROUP) 
■(SPECIFIC  PRE  CtX>E  CROUP) 

■(HOLD  AREA  FOR  SUBROUTINE  6000) 


REN  SINCLUDE:  'RACCMN.MaO' 


REM  INCLUDE  THE  COMMON  AREA  DEFINITION 


*  NAME:  RACCMN.MOO  COMMON  AREA  DEFINITION  • 

•  Date:  28  Feb  84  Written  by:  Floyd  Cole  • 

COMMON  AREA  DEFINITIONS  WILL  BE  HELD  IN  THIS  FILE.  IT  IS  AN 
INCLUDED  FILE  SO  IT  CANNOT  BE  RUN  IN  A  STANDULONE,  MODE. 

This  progran  segment  stay  be  modified,  but  all  files  containing 
an  include  for  this  segment  must  be  re*caapiled  In  order  to 
affect  the  changes  made  here. 

•••**********START  OF  COMMON  DEFINITIONS****"****************** 


COMMON  FORE, BACK, BOARD, HIDE, EFORE.EBACK.BELLS  'BASIC  SCREEN  COLORS 


COMMON  HEADERS 
COMMON  TEXTS 
COMMON  PGMIOS 
COMMON  MOLENGTHO 
COMMON  USERSO 
*************ENO 


■21  CHARACTER  SCANNER  HEADER  INFO 
■■  AIMING  CHARACTERS  FROM  SCANNER 
■PROGRAM  OR  FORM  ID 
■OATS  IN  THE  MONTH 


OF  COMMON  DEFINITION**** 


REM  SINCLUDE:  'RACDEF.MQO'  REM  INCLUDE  THE  DEFAULT  DEFINITIONS 

i**************e*e*eir*«***********************************«********«*** 

■•  NAME:  RACP01.DEF  DEFAULT  DEFINITIONS  * 

■•  Date:  28  Feb  84  Written  by:  Floyd  Cole  * 

■  Variables  used  in  coaiaon  that  have  a  default  value  on  start*up 

■  Hill  be  held  in  this  file.  It  is  an  included  file  so  it  cannot 

■  be  run  in  a  stand*alone  mode.  In  normal  operation,  this  file 

■  should  be  'included'  in  the  main  program  only  (RACP10.BAS). 

I 

■  This  program  segment  aiay  be  modified,  but  all  files  containing 

■  an  include  for  this  segment  must  be  re*compiled  in  order  to 

■  affect  the  changes  made  here. 


•************START  OF  DEFAULT  DEFINITION********* 
FORE  =  15  'FOREGROUND  COLOR  >  INTENSE  WHITE 

BACK  '  1  'Background  Color  •  Light  Blue 

BORO  3  4  'BORDER  «  RED 

HIDE  >  4  ’ALTERNATE  COLOR  >  RED 

EFORE=  14  'ERROR  FOREGROUND  OISPLAT 

E8ACK-  0  'ERROR  BACKGROUND  D I  SPLAT 

BELLS  =  CHR$(7)  'Sound  the  bell 


RACP940 

PAGE  4 

SHORT  FORM 

07-06-87 

15:07:19 

Offset 

Data 

Source  Line 

IBM  Personal 

Conputer  BASIC:  Canpi  ler  VI  .  JO 

0078 

1102 

MOLENGTHd) 

S 

31  'JAN 

007F 

1102 

HOLENGTH(2> 

s 

28  'FEB  <--HQOIFIEO  IN  SUBROUTINE  RACS5000.SUB 

0086 

1102 

MOLENGTH(3> 

s 

31  'MAR 

0080 

1102 

MOLENGTH(4} 

m 

30  'APR 

009« 

1102 

MOLENGTHfS) 

M 

31  'MAY 

009B 

1102 

M0LENGTH(6) 

s 

30  'JUN 

00A2 

1102 

NOLENGTH(7} 

m 

31  'JUL 

00A9 

1102 

M0LEHGTH(8) 

m 

31  'AUG 

OOBO 

1102 

MOLENGTH<9) 

a 

30  'SEP 

00B7 

1102 

MOLENGTH(IO) 

m 

31  'OCT 

OOBE 

1102 

MOLENGTH(H) 

M 

30  'NOV 

OOCS 

1102 

MOLENGTH(12) 

a 

31  'DEC 

OOCC 

1102 

OOCC 

1102 

DATEERRt(O) 

a 

a  n 

ooos 

1102 

DATEERRS(I) 

a 

“INVALID  MONTH" 

CODE 

1102 

0ATEERRS(2) 

a 

“INVALID  DAY  “ 

OOE7 

1102 

0ATEERRS(3} 

a 

“DAY  TCX3  LARGE  FOR  MONTH  COOED" 

OOFO 

1102 

OQFO 

1102 

MAXLENGTH 

a 

80  'MAXIMUM  LENGTH  Of  OUTPUT  RECORD 

00F7 

1104 

PADS 

a  « 

'PAD  CHARACTER  FOR  SHORT  RECORDS 

0100 

1108 

0100 

1108 

“END  OF  DEFAULT  DEFINITION*************^********* 

0100 

1108 

0100 

1108 

0100 

1108 

KEY  OFF 

0106 

1108 

0106 

1108 

REM  •••••••••••' 

0106 

1108 

REM  THE  FOLLOWING  VARIABLES  ARE  UNIQUE  TO  EACH  PROGRAM  AND  MUST 

0106 

1108 

REM  BE  CHANGED. 

0106 

1108 

I'M 

0106 

1108 

PGMTITLS 

3  '*! 

SHORT  FORM" 

010F 

HOC 

010F 

HOC 

PGMIDS  • 

“940"  'VALUE  RECEIVED  FROM  THE  SCANNER 

0118 

HOC 

'IN  HEADER  VARIABLE  'PROGRAMS' 

0118 

HOC 

0118 

HOC 

DATFILS  ' 

•  "VISIT.DAT"  'FILE  TO  BE  INPUT  TO  FOCUS 

0121 

1110 

0121 

1110 

REM  LENGTH  OF  STRING 

RECEIVED  FROM  THE  OMR.... 

0121 

1110 

HEADER  > 

21 

0128 

1112 

RESPONSE- 

231 

012F 

1114 

RECORDLENGTH 

°  HEADER  *  RESPONSE 

013A 

1116 

013A 

1116 

N.PROC 

«  16 

'  NUMBER  OF  PROCEDURES  FOR  THIS  FORM 

OKI 

1118 

OKI 

1118 

REM  **•*••*••*•' 

OKI 

1118 

OKI 

1118 

BTIMES::TIMES 

'SCAN  START  TIME 

01AA 

Hie 

OKA 

Hie 

OKA 

Hie 

REM  •••  ENCOUNTER  FORM  CLINIC  PREFIX  TABLE 

OKA 

me 

REM  CLINIC  1 

HI 

OKA 

Hie 

CLINIC1.PFXS<0)="  •' 

0153 

Hie 

CLINIC1.PFX$(1)=''8" 

015C 

Hie 

CLINIC1.PFX1(2)="0" 

IIACP940 
SHMT  FCnt 


PACE  S 
07-06-87 
15:07:19 

OffMt  Data  Sourea  Line  IBM  Personal  Conputer  BASIC  Conpiler  VI. 00 

0165  me  CLlNICl.PFXStS)*"^ 

016E  111C  CL1MIC1.PPX*<4>«“G" 

0177  me  aiMici.pfx$<5)«‘‘S“ 

0180  me 

0180  me  REH  *»*  PROVIDER  TIME  TABLE 

0180  me  PROVIDER.TIHES(0)>«000"  'HO  TINE 

0189  me  PROVIDER. TIHES(1)»002'‘  ■  2  MINUTES 

0192  me  PROVIDER. TIMES(2}>"00S"  ■  5  MINUTES 

019B  me  PROVIDER. TIHES<3)«»010"  <10  MINUTES 

01AA  me  PROVIDER. TIHESIAI^OOIS*  MS  MINUTES 

01AD  me  PROVIDER. T1HES(S)««020*  '20  MINUTES 

01B6  me  PROVIDER. TIHES(6)«»030"  *30  MINUTES 

01BF  me  PROVIDER. TIMES(7)***040"  <40  MINUTES 

0le8  me  PROVIDER. TIMESIEIVOOSO"  '50  MINUTES 

'1D1  me  PROVIDER. TIMES<9)><‘06a«  ‘60  MINUTES 

01DA  me 

01DA  me  REM  ***  ENeOUNTER  FORM  PROeEOURE  TABLE 

01DA  me  PROCEOSIOI^"  ■  :  ^ROC£DS(07)  »  "90037"  :  PR0CE0S(14)>  "87060" 

01F5  me  PR0CEDS(1)""59420"  :  PROeE0S<08)  «  "99096"  :  PR0eED$(15)«  "36415* 

0210  me  PROeEO$<2)*“937a6“  :  PROeE0S<09)  »  "99094"  :  PR0CEDS(16)=  "99097" 

022B  me  PR0CE0S(3)="90657«  :  PROCEOSdO)  «  "90700“ 

0230  me  PROCEDS<4)»"99091“  :  PROCEOSdl)  s  "86581" 

024F  me  PR0eEDS(5)«"99095"  :  PR0CED$d2)  •  "86582" 

0261  me  PR0CEDS<6)»"99092"  :  PROOEDSdS)  ■  "90601" 

0273  me 

0273  1110  REM  INCLUDE:  'UCABAMC.OPT'  INCLUDE  OUTPATIENT  UCA  TABLE 

0273  me 

/273  me  REH  SPACE 


RACPMO 
SHOtT  FORM 

Offset  Oats  Source  Line 

0273  111C  GOSU8  1000  •MAKE  SURE  THEY  ME  LOGGED  ON 

0278  111C  CLS 

027C  me  GOSU8  7000  'PRINT  SCREEN  HEADING 

0281  me 

0281  me  REN 

0281  me  REN 

0281  me  REN 

0281  me  REN 

0281  me 

0293  me 

0293  me  REN 

0293  me  REM 

0293  me  REN 

0293  me 

029E  me 

02A8  me 

02B4  HIE 

02B8  IHE 

0200  1 1 1E 

02E6  HIE 

02E6  HIE  REN 

02E6  HIE  REM 

02E6  IHE  REM 

02E6  HIE  REN 

02E6  HIE 

02EB  IHE 


0305 

1122 

0305 

1122 

REN 

START  SCANNER 

(SI) 

0305 

1122 

CHTRLOPT  *1  : 

GOSUB  9010 

0311 

1124 

IF  ERRMSGS  > 

"  ■  THEN  LPRINT  ERRNSGS  :  GOTO  30000 

032B 

1124 

032B 

1124 

LOCATE  22,25: 

PRINT  "PRESS  'ESC'  TO  TERMINATE  SCANNING  " 

0340 

1124 

REA0TYPE*3 

•FIRST  TINE  IN..  SCANNER  IS  STARTED.. 

0347 

1126 

0347 

1126 

REM 

0347 

1126 

REN 

SET  SCAN  SHEET  CALL  **** 

0347 

1126 

REM 

0347 

1126 

REM 

0347 

1126 

0347 

1126 

10 

REN  -  RETURN  POINT  TO  READ  NEXT  SHEET 

0348 

1126 

0348 

1126 

AS* INKEYS 

0351 

H2A 

IF  AS*CHRS(27)  THEN  GOTO  25000 

0367 

H2A 

0367 

H2A 

GOSUB  9020 

■SCAN  SUBROUTINE  -  GET  A  RECORD 

036C 

H2A 

IF  NI0S(ERRSTAT$,14,3)="415"  THEN  GOTO  25000 

0388 

H2E 

0388 

H2E 

TEXTS*"" 

•CLEAR  THE  INPUT  AREA 

0391 

H2E 

GOSUB  8000 

•DECODE  HEADER 

0396 

H2E 

GOSUB  8050 

•CHECK  FOR  END  OF  JOB/ENO  OF  BATCH 

0398 

H2E 

GOSUB  8200 

■DECODE  THE  RESPONSE  POSITIONS 

03A0 

H2E 

LITHOS  *  MIDt(TEXTS,22,8) 

03B2 

1132 

GOSUB  8070 

•CHECK  FOR  SCANNER  ERRORS 

0387 

1132 

GOSUB  8100 

■PRINT  THE  DATA  ON  THE  SCREEN 

»•••••*•••••••••*••••••**•••*****»•*••*•**••**••**********•••**•*** 

•••*  COMMUNICATIONS  SETUP 

••*••*•••••••••*•••••***•••••**•*****•*•••••*•••••*•*•***•****«*••• 

PROTOCOL 
GOSU8  9001 

IF  ERRMSGS  >  <•  <•  THEN  LPRINT  ERRNSGS  :  GOTO  30000 


CLEM  AND  DISPLAY  PROGRAM  SCREEN 

******** *»****»***»****»*»«»**»*»*»o«»*»**«>»**#«e«**«««»x«*»**** 

LPRINT  CHRSdS); 

WIDTH  •■LPT1:",160 

PAGE  ■  0  :  GOSUB  7100  'LINE  PRINTER  HEADING 
COLOR  U 

LOCATE  11,26  ;  PRINT  "SHORT  FORM  ■ 

COLOR  FORE, BACK, BORO 


****************************************************** 


OPEN  FILE  TO  CONTAIN  SCMNED  DATA 


***************************** 


OPEN  DAT  FILS  FOR  MPENO  AS  «1 


PACE  6 
07-06-87 
15:07:19 

IBM  Personal  Computer  BASIC  Conpiler  V1.00 


RACP940 

a 

PACE  7 

SHORT  FORM 

07-06-87 

- 

15:07:19 

Offset  Data 

Source  Line 

IBM  Personal  Computer  BASIC  Compiler  VI. 00 

"'3BC  1132 

03BC  1132 

03ac  1132  REN 

03BC  1132  REN 

03BC  1132  REM 

03BC  1132  REN 

03BC  1132  REM 

03BC  1132  REN 

03BC  1132  REM 

03BC  1132  REM 

03BC  1132  REM 

03BC  1132  REM 

03BC  1132  REM 

!.SBC  1132  REM 

03BC  1132  REM 


03BC 

1132 

REM 

03BC 

1132 

03BC 

1132 

H.ERR  >0  'COUNTS  THE  NUMBER  OF  ERRORS 

03C3 

1134 

03C3 

1134 

REM 

•••  LITHO  CODE  DONE  IN  BAS  PROGRAM  ••• 

03C3 

1134 

03C3 

1134 

REM 

•••  CLINIC  ID  **• 

03C3 

1134 

100 

CK.X*VAL{MI0$(TEXT$,30,1)) 

0309 

1136 

CK . COOS*M I 0$( TEXTS , 31 , 3) 

03EB 

113A 

REM 

GOSUB  5500  'VALIDATE  OUTP  UCA  CODE 

03E8 

113A 

REM 

IF  HT.5500  «  0  THEN  GOTO  101 

C3E8 

113A 

REM 

N.ERR  -  N.ERR  *  1 

03EB 

113A 

REM 

EO.MSG$CN.ERR)*"#1-2  INVALID  CLINIC  CODE" 

03EB 

113A 

03EB 

113A 

CL1.CX$=CLINIC1.PFXS(CK.X)  ♦  CK.COOS 

0403 

113E 

0403 

113E 

REM 

•••  VISIT  DATE 

0403 

113E 

104 

CMS=MI0S(0ATE$,1,2)  'CURRENT  MONTH 

0415 

1142 

YR$=MI0$(0ATES,9,2)  'CURRENT  YEAR 

0427 

1146 

X$=MI0$<TEXT$,34,4)  'MONTH  AND  OAT  FROM  FORM 

0439 

114A 

IF  LEFT$(X$,2)<=CMS  THEM  105  'OK,  USE  THIS  TEAR 

044E 

114A 

YRS=RIGHTS<STR$(VAl(YR$)-1),2)  'USE  LAST  YEAR 

04aE 

114A 

105 

VDATES  »  YRS  ♦  X$ 

047C 

IKE 

01S=MID$(X$,3,1) 

048E 

1152 

02$=MIDS(X$,4,1) 

04A0 

1156 

IF  01$="  "  AND  D2$<>"  "  THEN  RT. 5000*2  ;  GOTO  106 

04CE 

1158 

IF  D1$<>"  "  AND  DES*"  "  THEM  RT. 5000*2  :  GOTO  106 

04FC 

1158 

'EDIT  VISIT  DATE 

04FC 

1158 

CK.5000S* VDATES 

0505 

115C 

GOSUB  5000  'DATE  CHECK 

U50A 

115C 

CK.5010$*VOATES 

0513 

1160 

GOSUB  5010  'NUMERIC  STRING  CHECK 

0518 

1160 

IF  RT.5000  =  0  AND  RT.5010  =  0  THEN  GOTO  107 

053C 

1162 

106 

N.ERR*N.ERR»1 

054. 

1162 

ED.MSGS(M.ERR)="TOOATS  DATE  "  ♦  OATEERRS(RT.5000) 

056A 

1162 

056A 

1162 

REM 

PROVIDER  ID  (PREFIX  ♦  NUM) 

056A 

1162 

107 

PROV1.PFXS  =  hidkte:  T$,38,1) 

05  7C 

1166 

PROV1.NUHS  =  MI0S(rEXTS,39,4) 

REN  SINCLUDE:  'RACMMO.MOI  ■  INCLUDE  THE  SHORT  FORM  REFORMAT/EOIT  MOO 

***•  AMBULATORY  CARE  INFORMATION  SYSTEM  30  JUN  87  **** 

D  R  BOLLING 

MODULE  NAME  :  RACM940.M01  ***• 

SCANNER  PROGRAM  0  ;  940-SHORT  FORM 

*•**  PURPOSE  ;  REFORMAT/EDIT  THE  ENCOUNTER  •••• 

SHORT  FORM  OMR  RECORD. 


**•*  MODIFIED  30  JUN  87  TO  ALLOW  SPEC  PRE  COOES  TO  BE 

BE  BUBBLED  FOR  PROCEDURE.  ***• 

******************************************************************* 

*•••  RESERVED  LINE  NUMBERS  100-199 


MCP940 
SHORT  FORH 

Offset  Data  Source  Line 

0S8E  116A 

0S8E  116A 

0S8E  116A  SSN. OFFSET  =  43 

0595  116C  FMP.OFFSET  =  52 

059C  116E  TIM.OFFSET  »  54 

05A3  1170  UNL. OFFSET  »  55 

05AA  1172  PRC. OFFSET  »  60 

0581  1174  SPE.OFFSET  *  76 

0588  1176  TOT. OFFSET  »  42 

058F  1178  POINTER  »  0 

05C6  117A 

05C6  117A  FOR  1940  *  1  TO  5 

05CO  117A  SPE.CO0$<I940)=““  MMITIALIZE 

05E1  117C  NEXT  1940 

05F0  117C 

O5F0  117c  REM  LOOP  THROUGH  THE  FOLLOWING  CODE  5  TIMES  (1  FOR  EACH  GROUP) 
05F0  117C  FOR  1411  »  1  TO  5 

05F7  117C  REM  PATIENT  ID  (SSN+FMP) 

05F7  117C  110  SSN$=MID$(TEXTS,SSN.0FF:ET+P0INTER,9) 

060E  1180  FMP1=MIOS(TEXT$,FMP.OFFSET»POINTER,2) 

0625  1184 

0625  1184  PTI0S<I411)  «  SSNS+FMPS 

063E  1186  IF  I411»1  THEH  GOTO  112 

0640  1186  IF  PTI0S(I411)=STRING$<11,"  «)  THEH  GOTO  130 

0673  1186 

0673  1186  REM  •••  PROVIDER  TIME  *** 

0673  1186  112  X=VAL(MIO$(TEXT$,TIM.OFFSET+POINTER,1)) 

068E  1188  PTIM$(I411)=PROVIDER.TIMES(X) 

06A8  1188  IF  PTIM$(I411)<>"000"  THEN  114 

06C3  1188  N.ERR>eN.ERR+1 

06C8  1188  EO.MSG$(N.ERR)="NO  TIME  COOED  FOR  PART  '•♦STRS(I411) 

06E8  1188 

06E8  1188 

06E8  1188  REM  UNLISTED  PROCEDURE  ••• 

06E8  1188  114  AOOP$=MIDS<TEXT$,IJHL.OFFSET*POINTER,5) 

06FF  118C 

06FF  118C  REM  ••• 

06FF  118C  120 

0717  118C 

071C  118C 

072B  118E 

073A  118E 

0747  1190 

0750  1194 

077F  1194 


0790 

11% 

0790 

1194 

122 

IF  A0DP$="  "  THEN  126 

079E 

1194 

TOT=TOT  ♦  1 

07A6 

1194 

GROUPS(I411,TOT)=AODP$  'ADO  UNLISTED  PROC 

07BF 

1194 

TOT.PROC(I411)*TOT 

07CE 

1194 

07CE 

1194 

REM 

•**  SPECIFIC  PREASSIGNED  COOES  ••• 

07CE 

1194 

126 

INP.STO$=MID$(TEXTS,SPE.OFFSET+POINTER,9) 

07E5 

1198 

GOSUB  5700  'CONVERT  ARRAT 

PROCEDURE  COOES 

X$  ■  MIOS(TEXT$,PRC.OFFSET+POINTER,N.PROC) 

GOSUB  6000  'DECODE  THE  X$  STRING 

IF  TOT  s  0  THEN  GOTO  122 
TOT.PROC(I411)  «  TOT 
FOR  I411.A=  1  TO  TOT 
PTR=VAL(HOLD$(I411.A)) 

GR0UP$( I 4 1 1 , I 4 1 1 . A ) =PROCEDS( PTR ) 

NEXT  1411. A 
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RACP940 
SHORT  FORM 
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07EA  1198  $PE.CQOS(U11)>BUF.STOS  'UP  TO  9  TWO  DIGIT  COOES 

07fe  I19C 

07FE  119C 

07FE  119C  IF  TOT>0  AND  SPE.C00S(K11)««"  THEN  128  ELSE  130 

0830  119C 

0830  119C  128  N.ERR<N.ERR«1 

0838  119C  ED.MSG$(H.ERR)b"NO  PROCEDURE  OR  SPEC  PRE  CL  CODE  IN  PART  "i^STRSlUII) 

0855  119C 

0855  119C  130  POINTER  =  POINTER  ♦  TOT.OFFSET 

0860  119C  NEXT  1411 

0872  119C  199  REM 

0873  119C 

0873  119C  HEM . END  OF  MODULE  RACM940.M01 . 

0873  119C 

0873  119C 

0873  119C  IF  N.ERR  «  0  THEN  GOTO  997 

0882  1i9C  LPRINT  “LITHO  *  “.•LITHOS;"  ...  ERRORS" 

0894  119C  FOR  1997  ■  1  TO  N.ERR 

08A1  119E  LPRINT  USING  «###  ■;I997; 

08A0  11A0  LPRINT  "«»>  ";E0.MSGS(I997} 

0ac3  11 AO  NEXT  1997 

0804  11A0  LN.COUNT  "  LN. COUNT  *  N.ERR  *  1 

f  08E0  11A2  CNTRLOPT  «  6 

08E7  11A2  GOSUB  9010  'REJECT  THE  FORM 

C3EC  11A2  GOTO  998  'BYPASS  THE  DISK  WRITER.... 

08F0  11A2 

08F0  11A2  997  REM  SINCLUOE:  'RACM940.M02'  REM  INCLUDE  THE  BASE  ENCOUNTER  FORM  DISK  WRITER 

09Fl  11A2  REH  *««************«********^**************«**««****«*««*****«******»* 

OaFI  11A2  REM  AMBULATORY  CARE  INFORMATION  SYSTEM  19  MAR  87 

08F1  11A2  REM  ••••  D  R  BOLLING  *••• 

08F1  11A2  REM  *•••  MODULE  NAME  :  RACM940.M02 

OeFI  11A2  REM  ••••  SCANNER  PROGRAM  «  :  940-SHORT  FORM 

08F1  11A2  REM  •••• 

08F1  11A2  REM  *•••  PURPOSE  ;  CREATE  AND  WRITE  THE  DISK  *•»* 

08F1  11A2  REM  RECORD  FOR  INPUT  TO  FOCUS 

OaFI  11A2  REM 

08F1  11A2  REM  PROGRAM  ADDS  PREFIX  TO  LITHO  FOR  EACH  PATIENT  •••• 

08F1  11A2  REM  •«♦•*•***••••*•••*•***••••••••••*»••••*•*•••••••*•••*•••»*••*•**•• 

08F1  11A2  REH  *•••  RESERVED  LINE  NUMBERS  200-299  *••• 

08F1  11A2  .  REN 

08F1  11A2 

08F1  11A2  REH  BUILD  THE  OUTPUT  RECORD 

08F1  11A2 

08F1  11A2  GOSUB  270  'BUILD  THE  RECORD  KEY 

08F6  11A2 

08F6  11A2  REH 

08FJ  11A2  REM 

08F6  11A2  REH 

08F6  11A2 

03FF  11A6 

0908  11AA 

0908  11AA  FOR  1412  *  1  TO  5 

090F  11AA  IF  PTID$(I412)=STRIMG$<11,"  '■)  THEN  GOTO  210 

0935  11AC  RECOUTS  »  ''9401''  ♦  RECKEYS  ♦  RIGHTt<STR$(I412),1)  ♦  RIGHTS(lITH0S,7) 


RECORD  TYPE  "1"  -  RECKEY  PLUS  TRANSACTION  1  DATA 


VCNTS  =  "0"  'DEFAULT  COUNT  IS  0  FOR  THIS  FORM 
FRMNS  =  "94"  'FORM  NUMBER 


RACP940 
SHORT  FORM 
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0965 

11B4 

NI0S(RECaurS,20,11)<PTI0S<I412) 

0970 

1184 

RECOUTS  «RECOUTS  *  FRMNS  ♦  VCNTS  «PTIMS(I412)  *  STRIHCS(30,"  ■) 

09B8 

11B4 

GOSU8  280 

0980 

11B4 

PRINT  #1, RECOUTS 

09C8 

11B4 

210 

NEXT  1412 

09DA 

11B4 

090A 

11B4 

REM 

090A 

11B4 

REM 

RECORD  TYPE  "2"  -  RECKEY  PLUS  PROCEOURE  CODE 

090A 

11B4 

REM 

*«««*•«***«**«•**«*«*••«»«**••••*•**««****«*««****•«*****«•**«•••** 

09DA 

1184 

REM 

RECOUTS  •"9402"«RECKEYS  'TRANSACTION  IDENTIFIER 

090A 

11B4 

09DA 

11B4 

FOR  1412  >  1  TO  5 

09E1 

1184 

IF  PTI0S(I412)>STRINGS<11,"  ")  THEN  GOTO  250 

0A07 

1184 

FOR  I412.A  ■  1  TO  TOT. PROC( 1412} 

0A1B 

1186 

RECOUTS  >  •^402"  -»  RECKEYS  «  RIGHTS(STRS(1412),1)  *  RIGHTS(LITHOS,7) 

0A4B 

11B6 

HIOSIRECOUTS, 20, 1 1 )"PT IDS( 141 2) 

0A63 

11B6 

RECOUTS  XRECQUTS  *  FRMNS  *  "1"  +  GROUPS(I412.I412.A} 

0A8F 

1188 

GOSUB  280 

0A9A 

11B8 

PRINT  #1, RECOUTS 

0A9F 

11B8 

NEXT  I412.A 

0AB3 

11B8 

250 

NEXT  1412 

OACS 

11B8 

OACS 

11B8 

REM 

OACS 

11B8 

REN 

RECORD  TYPE  "3"  -  RECKEY  PLUS  SPE  PRE  CLINIC  COOES  •**" 

OACS 

11B8 

REM 

•««««**«*«*«*«*-*1»«««««**««*««««**«***««***«******«****«******««***« 

OACS 

11B8 

FOR  1412  >  1  TO  5 

OACC 

11B8 

IF  LEN(SPE.C00S(1412))«0  THEN  260 

0AE2 

1188 

RPOINT  ■  1 

0AE9 

11BA 

0AE9 

11BA 

252 

RECQ03S"R I GHTS<H I 0S( SPE . COOS( 1412), RPOINT, 2), 1) 

OBOB 

11BE 

IF  REC003S»"  "  THEN  254 

0819 

11BE 

0819 

11BE 

RECOUTS  •  "9403"  ♦  RECKEYS  ♦  RIGHTS(STRS(1412),1)  ♦  RIGHTS<LITH0S,7) 

0849 

11BE 

HIDS(RECOUTS,20,11)3PTIOS(I412) 

0861 

11BE 

RECOUTS  iRECOUTS  +  FRMNS  *  REC003S 

0B74 

11BE 

GOSUB  280 

OB  79 

11BE 

PRINT  #1, RECOUTS 

0B84 

11BE 

0884 

11BE 

254 

RPOINT  ■  RPOINT  ♦  2 

0B8O 

11BE 

IF  RPOINT  <  LEN(SPE.COOS(I412))  THEN  252 

0BA5 

11BE 

0BA5 

11BE 

260 

NEXT  1412 

0BB7 

11BE 

0BB7 

11BE 

REM  END  OF  TYPE  3  RECORDS 

08B7 

11BE 

0BB7 

11BE 

GOTO  299 

0888 

11BE 

OBBB 

11BE 

REM 

OBBB 

11BE 

REM 

••••  SUBROUTINE  270  •  BUILD  THE  RECORD  KEY  •••* 

OBBB 

11BE 

REM 

OBBB 

11BE 

270 

RECKEYSs"" 

08C4 

11BE 

0BC4 

11BE 

REN 

**•  CLINIC  ID  (PREFIX  ♦  CODE)  ••• 

0BC4 

11BE 

RECKEYS>  CL  1. COOS 

IUCP940 
SHORT  FORM 
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OBCD  IIBC 

OBCO  11BE  REM  •**  VISIT  DATE  ••• 

OBCO  11 BE  RECKETS>RECKEY$*  VDATES 

0809  USE 

0809  11BE  REM  •**  PROVIDER  10  (PREFIX  ♦  MM)  *** 

OB09  11BE  RECKETS  «  REOCEYS  *  PROV1.PFXS  *  PROVI.MMS 

OBEC  11  BE 

C8EC  11BE  HEM  PATIEHT  ID  (SSN+FMP)  *** 

OBEC  11BE  RECKEYS  >  RECKEYS  «  STRIMGS(11.«  «} 

OBFE  11BE 

OBFE  11BE  REM  **•  LITHO  CODE 

OBFE  11BE  REM  DO  LITHO  IH  LOOP  ABOVE 

OBFE  11 BE  REM  RECKEYS  -  RECKEYS  *  LITHOS 

OBFE  11  BE 

OBFE  118E  RETURN 

3C01  11 BE 


OCOI  1 1BE  REM 

0C01  11BE  REM  **•*  SUBROUTINE  280  -  PAD  THE  RECORD  TO  MAXLEHGTH  **** 

OCOI  118E  280  PAD>MAXLEHGTH  •  LEN(RECOUTS)  'FIHD  OUT  HOW  SHORT  THE  RECORD  IS 

OCOF  11C0  RECOUTS  >  RECOUTS  *  STRIHGS(PAD,PAOS)  'PAD  THE  RECORD  WITH  FILL  CHAR 

0C22  11 CO  RETURH 

0C2S  11C0 
0C25  11C0 


0C2S  11  CO  299  REM 

0C26  11 CO 

0C26  11C0  REM  . END  OF  MODULE  RACM940.H02 . 

0C26  11 CO 

UC26  11 CO  998  REM  CONTINUE 

0C27  11C0 

0C27  11C0  999  REAOTYPE  »  2 

0C2E  11C0  IF  LN. COUNT  >  68  THEN  GOSUB  7100  'PRINTER  HEADING 

0C3E  11C0  GOTO  10 

0C62  11 CO 

0C42  11  CO  REM  END  OF  SCAN/OECOOE/URITE  LOOP  *x==»=s==.».m.=======.=«=**===xs==== 

0C62  11 CO 

0C62  11C0  1000  REM  SINCLUDE:  'R ACS 1000. SUB'  INCLUDE  THE  VERIFY  LOGON  SUB 

0C43  1 1 CO  REM  *•**«•**•••*•***••**•**•*•*••*«♦«**•*«*«*«**•*•«**«♦«*•«•*•««***««•** 

0C43  11C0  REM  *  NAME;  RACS100Q  LOGON  VERIFICATION  SUBROUTINE  * 

0C43  11C0  REM  *  Date:  25  Feb  84  PATIENT  REGISTRATION  PROGRAM  * 

0  43  11 CO  REM  *♦**♦******♦******♦***♦**<*****************••♦*♦**♦♦**♦♦****♦♦»******* 

0C63  11C0  REN  PATIENT  OMR  INPUT  PROGRAM  * 

0C43  11C0  REM  • 

0C63  11C0  REM  This  program  verifies  user  is  logged  on  properly.  If  there  is  no  * 

0C63  11C0  REN  valid  user  logged  on  at  the  time  of  execution,  this  subroutine  will* 

0C43  11C0  REM  chain  to  the  logon  program  RACPOS,  otherwise  a  return  is  issued.  * 

0C43  1 ICO  REM  ********************************************************************* 

0C43  11C0  REM  RESERVED  LINE  NUMBERS  ARE  1001  THRU  1010 

0C43  1 ICO  REM  *********************************^********************************** 

0C43  11C0  1001  OPEN  ''I'',1,"RACLOG.OAT'' 


0C55  11C0  IF  E0F(1)  THEN  1002  'MAKE  THEM  LOG  ON  FIRST 

0C63  11C0  INPUT  #1,USERS(1),DTS,TMS,P10S 

OC^'4  11CC  IF  USERSd)  =  THEN  1002  'MAKE  THEM  LOG  ON  FIRST 

0C92  11CC  IF  USERS(I)  *  THEN  1002  'MAKE  THEM  LOG  ON  FIRST 
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11CC 

OCDA 

11CC 

OCDA 

11CC 

OCDE 

11CC 

0CE5 

11CC 

0CE5 

11CC 

0CE5 

11CC 

0CE6 

11CC 

0CE6 

11CC 

0CE6 

11CC 

0CE6 

11CC 

0CE6 

11CC 

0CE6 

11CC 

0CE6 

11CC 

0CE6 

11CC 

0CE6 

11CC 

0CE6 

11CC 

0CE6 

11CC 

0CE6 

11CC 

0CE6 

11CC 

0CE6 

11CC 

0CE6 

11CC 

0CE6 

11CC 

0CE7 

11CC 

OCFB 

1100 

no5 

1102 

0D20 

1102 

004C 

1102 

004  F 

1102 

004  F 

1102 

0050 

1102 

0050 

1102 

0050 

1102 

0050 

1102 

0050 

1102 

0050 

1102 

0050 

1102 

0050 

1102 

0050 

1102 

0050 

1102 

0050 

1102 

0050 

1102 

0050 

1102 

0050 

1102 

0050 

1102 

0050 

1102 

0050 

1102 

0050 

1102 

0050 

1102 

0050 

1102 
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Sourct  Line  IBM  Personal  Coofxiter  BASIC  Compiler  V1.00 

CLOSE  1 

SCREEN  0,1, 0,0 
COLOR  FORE, BACK, BORO 
CLS 
RETURN 

1002  CLOSE 

CHAIN  "RACP05” 

•  of  logon  VERIFY  SUBROUTINE  1000«»«»*»«»««««««»“““«”“» 


2000 

REM 

REM 

REM  SINCLUDE:  'RACSEOOO.SUB' 

INCLUDE  THE  REPLY/DELAY  SUB 

AMBULATORY  CARE  DATA  BASE  13  APR  85 

*«*« 

REM 

SKIP  COLE 

**** 

REM 

•**« 

SUBROUTINE  NAME 

RACS2000.SUS 

»*«• 

REM 

SCANNER  PROGRAM  « 

:  ALL 

**«« 

REM 

FUNCTION 

:  THIS  SUBROUTINE  MODULE 

**** 

REM 

*««« 

SERVERS  AS  A  WAIT  AND  REPLY 

*«*« 

REM 

*«** 

ENTRY  MODULE 

*•*« 

REM 

INPUT 

:  SINGLE  KEYBOARD  ENTRY 

•**« 

REM 

REM 

*«•« 

OUTPUT 

:  KEYBOARD  ENTRY  -  UPPER  USE 

***« 

REM 

REM 

•««« 

RESERVED  LINE 

***« 

REM 

NUMBERS 

:  2001-2010 

REM 

2001 

2002 

REM  REPLY  FUNCTION 

REPLY$=IHKEY$  :  IF  REPLY$="" 

THEN  2002 

REPLT>ASC(REPLYS) 

IF  REPLY  »  90  THEN  REPLYS=CHR$<REPLY  XOR  32)  'CONVERT  TO  CAPS 
IF  REPLYS  <  "A"  OR  REPLYS  >  "2"  THEN  REPLTS»“7" 

RETURN 


5000 

REM 

REM 

REM 

REM 

REM 

REM 

REM 

REM 

REM 

REM 

REM 

REM 

REM 

REM 

REM 

REM 

REM 

REM 

REM 

REM 


REM  SINCLUDE:  'RACS5000.SUB'  INCLUDE  THE  DATE  EDITOR  SUB 


*«*• 


**** 

•**« 


**** 

**** 
***# 
•*** 
**«* 
***• 
•  **« 


AMBULATORY  CARE  DATA  BASE  13  APR  85 


SKIP  COLE 


SUBROUTINE  NAME 

RXXS5000.SUB 

•••ft 

SCANNER  PROGRAM  #  : 

ALL 

•••ft 

FUNCTION  : 

THIS  SUBROUTINE  MODULE 

•••ft 

PERFORMS  A  DATE  EDIT 

•••ft 

•••ft 

INPUT  : 

DATE  TO  BE  CHECKED  MUST  BE 

•••ft 

IN  THE  VARIABLE  NAMED 

•••ft 

•CK.5000S' 

•••ft 

IN  THE  FORMAT  "YYMMDO" 

•••ft 

•••ft 

OUTPUT  : 

'RT.5000'  IS  THE  RETURN  CODE 

•••ft 

VARIABLE.  IF  THIS  VARIABLE 

•••ft 

CONTAINS  ANY  NUMBER  OTHER 

•••ft 

THAN  0,  AN  ERROR  WAS  FOUND 

•••ft 

IN  THE  DATE. 

•*•• 

•••* 

RESERVED  LINE 


**«* 


KACPWO 
SHMT  FOm 


rffs«t 

0050 

0050 

0050 

0057 

006A 

0080 

0093 

0093 

0OA9 

OOBF 

0005 

JOES 

OOEB 

ODEB 

0OF2 

0E01 

0E16 

0E1D 

0E1D 

0E3C 

0E3C 

0E3F 

0E3f 

0E3F 

0E3F 

0E40 

0E4O 

0E40 

OE40 

OE40 

OE40 

0E4O 

0E40 

0E40 

OE40 

0L40 

0E40 

OE40 

0E40 

0E40 

0E40 

0E40 

0E4O 

0E40 

0E40 

0E40 

0E40 

0E41 

0E47 

0E47 

0E57 

0E63 

0E93 

0EA4 


Data 

Source 

11D2 

REM 

1102 

REM 

1102 

11D2 

11D4 

11D6 

11D8 

1108 

11D8 

11D8 

11D8 

1108 

11D8 

REM 

1108 

1108 

11DS 

11D8 

1108 

11D8 

5005 

1108 

11D8 

5009 

1108 

1108 

REM  -• 

1108 

1108 

5010 

1108 

REM 

1108 

REM 

1108 

REM 

1108 

REM 

1108 

REM 

1108 

REM 

1108 

REM 

1108 

REM 

1108 

REN 

1108 

REM 

1108 

REM 

1108 

REM 

1108 

REM 

1108 

REM 

1108 

REM 

1108 

REM 

1108 

REM 

1108 

REN 

1108 

REN 

1108 

REN 

1108 

REN 

1108 

REM 

1108 

1108 

1108 

110A 

110E 

110E 

110E 
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NUMBERS 


5001-5009 


RT.5000 

CKYEAR 

CKNONTH 

CKDAY 


VAL(LEFTS<a(.5000S.2)) 
VAL(HIOS<CK. 5000S. 3 , 2) } 
VAL(RIGHT$(CK.5000t,2)) 


•YEAR  NUMERIC  VALUE 
•MONTH  NUMERIC  VALUE 
•DAY  NUMERIC  VALUE 


IF  CKMONTH  <  1  THEN  RT. 5000-1  :  GOTO  5009 

IF  CKMONTH  >  12  THEN  RT. 5000-1  :  GOTO  5009 

IF  CKDAY  <  1  THEN  RT. 5000-2  :  GOTO  5009 

IF  CKDAY  >  31  THEN  RT. 5000-2  :  GOTO  5009 

LEAP  YEAR  CHECK 
NOLENGTH(2)  -  28 

IF  CKMONTHo  2  THEH  GOTO  5005  •MUST  BE  FEBRUARY 

IF  (CKYEAR  MOO  4)  <>  0  THEN  GOTO  5005  •MUST  BE  A  LEAP  YEAR 
HOLENGTH(2)  -  29 


-ENO  OF  SUBROUTINE  5000 


REM  SINCLUDE:  •RACS5010.SUB'  INCLUDE  THE  NIMERIC  STRING  EDITOR 


**«* 
— •* 
*•— 
***• 


AMBULATORY  CARE  DATA  BASE 


SUBROUTINE  NAME 
SCANNER  PROGRAM  « 
FUNCTION 


INPUT 


•••• 

•*— 


OUTPUT 


«*** 

*«** 

*— 

*—* 


1  MAY  85 
SKIP  COLE 

RXXS5010.SUB 

ALL 

THIS  SUBROUTINE  MODULE 
PERFORMS  A  NUMERIC  STRING 
EDIT, 

STRING  TO  BE  EDITED  IS  IN 
THE  VARIABLE  NAMED 
•CK.5010S^ 

•RT.5010^  IS  THE  RETURN  CODE 
VARIABLE.  IF  THIS  VARIABLE 
CONTAINS  ANY  NUMBER  OTHER 
THAN  0,  AN  ERROR  WAS  FOUND 
IN  THE  STRING. 


•*** 

*♦— 

*— 

**** 

*«*• 

•••• 


**— 

**** 

**— 


•••* 


RESERVED  LINE 
NUMBERS 


*— * 
•*** 


:  5011-5019 

**—**•*********— ***•—****—*****••«•***••*•—*••**********•*«*** 

RT.5010  =  0 

FOR  15010  -  1  TO  LEM(CK.5010$) 

J5010-  ASC(MIDS(CK. 5010$, 15010,1)) 

IF  J5010  <  48  OR  J5010  >  57  THEN  RT.5010  =  RT.5010  ♦  1 
NEXT  15010 
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0EA4 

0EA7 

11DE 

RETURN 

0EA7 

11DE 

5500 

REM  INCLUDE:  'RACSSSOO.SUB' 

INCLUDE  THE  OUTPATIENT  UCA  CHECK 

SUB 

OEAS 

0EA9 

11DE 

110E 

5700 

REM 

REM  SINCLUDE:  'RACSSTOO.SUB' 

INCLUDE  THE  ARRAY  CONVERTER  SUB 

jj  •• 

* 

0EA9 

11DE 

REM 

*«** 

AMBULATORY  CARE  DATA 

BASE  29  JUL  85 

**«« 

0EA9 

11DE 

REN 

«•*« 

D  R  BOLLING 

0EA9 

11DE 

REM 

***« 

SUBROUTINE  NAME 

RXXS5700.SUB 

0EA9 

110E 

REM 

SCANNER  PROGRAM  t 

ALL 

•*«* 

0EA9 

11DE 

REM 

FUNCTION 

THIS  SUBROUTINE  MODULE 

0EA9 

11DE 

REM 

**«* 

CONVERTS  A  BINARY  ARRAY  INTO 

•*** 

0EA9 

11DE 

REN 

***• 

TUO  CHAR  COOES. 

0EA9 

11DE 

REM 

0EA9 

11DE 

REN 

•*** 

INPUT 

INP.STOS  AS  STRING 

0EA9 

110E 

REN 

*«** 

0EA9 

110E 

REN 

***• 

0EA9 

110E 

REN 

OUTPUT 

BUF.STOS  AS  STRING. 

0EA9 

11DE 

REN 

**** 

0EA9 

110E 

REN 

0EA9 

11DE 

REM 

**** 

RESERVED  LINE 

**** 

0EA9 

0EA9 

11DE 

110E 

REM 

REN 

NUMBERS 

5710-5730 

jaAJJAAAAiiatAIAAitAOaii  •••••• 

0EA9 

11DE 

0EA9 

110E 

8UF.ST0S*"" 

0EB2 

11DE 

H.ST0*1 

0EB9 

11E0 

5710 

X.STa*INSTR(N.ST0,INP.ST0S,«1“) 

OECB 

11E2 

IF  X.STO»0  THEN  GOTO  5720  'THATS  ALL 

OEDA 

11E2 

N.STO  « 

X.STO  ♦  1  'NEXT  STARTING  POINT 

0EE2 

11E2 

X.STO  ■ 

X.STO  ♦  100  'PAD  WITH  LEADING  2ERO 

OEEC 

11E2 

BUF.STOS  «  BUF.STOS  *  RIGHTS(STR$(X.ST0),2) 

0F02 

11E2 

IF  N.STO  <=  LENdNP.STOS)  THEN  GOTO  5710 

0F15 

11E2 

0F15 

11E2 

5720 

RETURN 

0F1S 

11E2 

0F1S 

11E2 

nrsa 

REN 

0F18 

11E2 

0F18 

11E2 

6000 

REM  SINCLUDE:  •RACS6000.SUB' 

INCLUDE  THE  INSTRINC  DECODE  ROUTINE 

0F19 

11E2 

REN 

0F19 

11E2 

REM 

AMBULATORY  CARE  DATA 

BASE  13  APR  85 

0F19 

11E2 

REM 

SKIP  COLE 

0F19 

11E2 

REN 

•**« 

SUBROUTINE  NAME 

RXXS6000.SUB 

0F19 

11E2 

REN 

SCANNER  PROGRAM  « 

ALL 

OF  19 

11E2 

REM 

**•* 

FUNCTION 

THIS  SUBROUTINE  MODULE 

0F19 

11E2 

REN 

PERFORMS  INSTRING  SEARCH 

0F19 

11E2 

REM 

0F19 

11E2 

REM 

•  ••* 

INPUT 

STRING  TO  BE  SEARCHED  MUST 

0F19 

11E2 

REN 

BE  IN  THE  VARIABLE  NAMED  : 

OF  19 

11E2 

REN 

•XS' 

0F19 

11E2 

REN 

•*** 

OF  19 

11E2 

REN 

OUTPUT 

■TOT*  »  TOTAL  NUMBER  OF 

0F19 

11E2 

REM 

HITS  IN  THE  DESTRINC 

0F19 

11E2 

REN 

■HOLOSO'  IS  THE  ARRAY 

0F19 

11E2 

REM 

CONTAINING  THE  NUMERIC 

0F19 

11E2 

REN 

•  *** 

VALUE  OF  THE  HIT  POSITIONS 

**•* 

RACP940 
SHORT  FORM 


PAGE  IS 
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Offset 

Otta 

Source  Line 

IB» 

0F19 

11E2 

REH 

**** 

•«** 

0F19 

11E2 

REM 

0F19 

11E2 

REM 

*«sr* 

RESERVED  LINE 

**** 

0F19 

0F19 

11E2 

11E2 

REH 

REM 

•**« 

NUMBERS 

6001-6009 

444444444444444444444  4 

*«** 

0F19 

11E2 

6001 

PTR  »  INSTR(XS,"1") 

0F27 

11E2 

TOT  »  0 

1F2E 

11E2 

WHILE 

PTR  >  0 

0F39 

11E2 

T0T«T0T+1 

0F41 

11E2 

HOLO$(TOT)  X  RICHTS(STRS<PTR).2} 

0F63 

11E2 

PTR«PTR*1 

3F6B 

11E2 

PTR  »  INSTR(PTR,XS,«1 

") 

0F7D 

11E2 

UENO 

0FS1 

0F84 

0F8A 

11E2 

11E2 

11E2 

RETURN 

RtN 

0FS4 

11E2 

0F84 

11E2 

0F84 

11E2 

7000 

REM  SINC'.'DE:  'RACSTOOO.SUa' 

INCLUDE  THE  SCREEN  HEADER  SUB 

0F8S 

11E2 

REH 

.F85 

11E2 

REH 

*«*• 

AMBUUTORY  CARE  DATA  BASE  13  APR  SS 

gF8S 

11E2 

REM 

**** 

SKIP  COLE 

»tk** 

0F8S 

11E2 

REN 

IHUHt 

SUBROUTINE  NAME 

RACS7000.SUB 

0F65 

11E2 

REH 

«««• 

SCANNER  PROGRAM  # 

ALL 

•••* 

CF85 

11E2 

REH 

FUNCTION 

THIS  SUBROUTINE  MODULE 

«•«« 

0FS5 

11E2 

REM 

***• 

PRINTS  THE  STANDARD  SCREEN 

»««« 

0F8S 

11E2 

REH 

HEADING. 

0F85 

11E2 

REM 

INPUT 

COMMON  VARIABLE  USER$(2) 

0F85 

11E2 

REM 

SYSTEM  DATE 

•*** 

0F8S 

11E2 

REM 

**** 

0F8S 

11E2 

REM 

•*«* 

OUTPUT  :  SCREEN  HEADING 

..F85 

11E2 

REM 

0F8S 

11E2 

REH 

RESERVED  LINE 

0F8S 

0F8S 

11E2 

11E2 

REM 

NUMBERS 

7001-7010 

•*** 

REM 

0F85 

11E2 

0F8S 

11E2 

7001 

LOCATE 

1.1 

0F8F 

11E2 

PRINT  "O.S.  ARMY  AMBULATORY  CARE  INFORMATION  SYSTEM" 

0F97 

11E2 

LOCATE 

1.65 

0FA4 

11E2 

PRINT  OATES; 

OFAC 

11E2 

LOCATE 

2.1 

0FB9 

11E2 

PRINT  "USER  ;  ";USER$(1) 

0FC6 

11E2 

RETURN 

0Fw9 

11E2 

7100 

REM  SINCLUDE:  <RAC57100.SUB' 

INCLUDE  THE  PRINTER  HEADER  SUB 

OFCA 

11E2 

REM 

OFCA 

11E2 

REH 

•**« 

AMBULATORY  CARE  DATA  BASE  13  APR  85 

**** 

OFCA 

11E2 

REH 

**** 

SKIP  COLE 

**** 

OFCA 

11E2 

REH 

SUBROUTINE  NAME 

RXXS7100.SUB 

•*«* 

OFCA 

11E2 

REH 

*•*« 

SCANNER  PROGRAM  « 

ALL 

**** 

OFCA 

11E2 

REH 

*••• 

FUNCTION 

THIS  SUBROUTINE  MODULE 

***• 

OFCA 

iie2 

REH 

PRINTS  THE  STANDARD  HEADING 

*«** 

OFCA 

11E2 

REM 

ON  THE  PRINTER. 

OFCA 

11E2 

REH 

**•* 

INPUT 

DATE.PAGE.PGMIDt.PGMTITLS 

*«** 

**** 


Memo 

SNORT  FORM 
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Offset 

Oata 

Source  Line 

IBM  Personal  Coiqputer  BASIC  CoirpUer  VI. 00 

OFCA 

11E2 

REM 

OUTPUT  :  PRINTER  HEADING,  LN.COUNT 

OFCA 

11E2 

REM 

OFCA 

11E2 

REM 

RESERVED  LINE 

OFCA 

11E2 

REM 

NUMBERS  :  7101-7110 

k******************************************!************! 

****** 

OFCA 

11E2 

REM 

OFCA 

11E2 

OFCA 

11E2 

7101 

IF  PAGE  >  0  THEN  LPRINT  CHRS(12); 

0F?0 

11E2 

LPRINT 

••ARMY  AMBULATORY  OARE  INFORMATION  SYSTEM _ ■.-PGMTITLS 

OFEO 

11E2 

LPRINT 

TA8(70};0ATES 

1000 

11E2 

PAGE*PAGE«1 

1008 

11E2 

LPRINT 

■•PROGRAM  ■;PGMI0S;TAB(70);^^PAGE^'; 

1025 

11E2 

LPRINT 

USING  *«ttM«;PAGE 

1031 

11E2 

LPRINT 

1039 

11E2 

LN.CCUNT°3 

1040 

11E2 

RETURN 

1043 

11E2 

1043 

11E2 

8000 

REM  SINCLUDE:  •RACS8000.SU8'  INCLUDE  THE  DECODE  SIA  GROUP 

^***** 

1044 

11E2 

REM 

10U 

11E2 

REM 

**«« 

AMBULATORY  CARE  OATA  BASE  13  APR  85 

loa 

11E2 

REN 

**** 

SKIP  COLE 

*** 

1044 

11E2 

REM 

SUBROUTINE  NAME  :  RXXSSOOO.Sin 

1044 

11E2 

REM 

SCANNER  PROGRAM  #  :  ALL 

1044 

11E2 

REM 

«««• 

FUNCTION  :  THIS  SUBROUTINE  MODULE 

1044 

11E2 

REM 

*«*« 

IS  A  GROUPING  THAT  PERFORMS 

1044 

11E2 

REM 

VARIOUS  DECODING  FUNCTIONS 

1044 

11E2 

REM 

ON  THE  SCANNER  DATA 

1044 

11E2 

REM 

1044 

11E2 

REM 

8001  •  DECODE  THE  HEADER  POSITIONS  (POINTER  0-20) 

1044 

11E2 

REM 

8050  -  CHECK  FOR  END  OF  JOB 

1044 

11E2 

REN 

8100  -  PRINT  THE  HEADER  DATA  ON  THE  SCREEN 

1044 

11E2 

REN 

8200  •  DECODE  THE  RESPONSE  POSITIONS  (POINTER  21 -. 

.)  *** 

lOU 

11E2 

REN 

(RETURNED  IN  TEXTS  STRING  VARIABLE) 

1044 

11E2 

REN 

**•« 

1044 

11E2 

REN 

INPUT  :  SHEET  RECORD,  RECORD  LENGTH 

10U 

11E2 

REN 

1044 

11E2 

REN 

OUTPUT  :  •TEXTS^  TRING  VARIABLE 

*•* 

10U 

11E2 

REN 

#*«• 

1044 

11E2 

REN 

RESERVED  LINE 

*«• 

1044 

11E2 

REN 

NUMBERS  :  8001 -8500 

1044 

11E2 

REM 

•*#«•«*««•*«•«•*****«*****••*«*••***«•♦««•*«•«**••#«••••*••*«*•*•«* 

1044 

11E2 

1044 

11E2 

■DECODE  THE 

HEADER  ONLY 

1044 

11E2 

8001 

POINTER  >  0 

1048 

11E2 

RECOROPTR  >  VARPTR(SHEETREC(0)} 

1052 

11E4 

FOR  J8000  *  1  TO  21 

1059 

11E4 

8002 

TEXTS*  TEXTS+CHRS(PEEK(RECORDPTR  *  POINTER)) 

1077 

11E4 

P0IHTER*P0IMTER+1 

107F 

11E4 

NEXT  J8000 

108E 

11E6 

PROGRAMS*  LEFTS(TEXTS,3) 

1090 

11EA 

BATCHS*  NIDS(TEXTS,4,3) 

10AF 

11EE 

SERIALS*  MID$(TEXTS,7,4) 

10C1 

11F2 

RUNIOS*  MIDS<TEXTS,11,1) 

1003 

11F6 

FORMS*  NI0S(TEXTS,12,2) 

10E5 

UFA 

POCKETS*  MIDS(TEXTS,14,1) 

kACP940 
SHORT  FORM 

OffMt  Data  Source  Line 
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c» 


i 


10F7 

1109 

1118 

112D 

1131 

1131 

1132 
'1U 
1152 
115A 
1167 
1174 
1181 
118C 
1190 

1190 

1191 
11A3 
IIAB 
11B3 
.ICO 
11C0 
11D5 
1100 
11E1 
11E1 
11E2 
11FC 
11FC 
1209 
1216 
1223 
1230 
1234 

1234 

1235 
123C 
1243 
1250 
126E 
1276 
1287 
12  !7 
1284 


11FE 
1202 
1206 
120A 
120A 
120A 
120A 
120A 
120A 
120A 
120A 
120A 
120  A 
120  A 
120A 
120A 
120A 
120A 
120A 
120A 
120  A 
120  A 
120A 
120C 
120C 
120C 
120C 
120C 
120C 
120C 
120C 
120C 
120C 
120C 
120C 
120C 
120C 
120C 
120E 
120E 
120E 
120E 
120E 
120E 


SCANERR1$«MIDS<TEXTS, 16,2) 

SCAIIERR2$>M10S(TEXTS,  18,2) 
SCANERR3$sMIDS<TEXTS,20,2) 

GOTO  8500 

8050  REH  CHECK  FOR  END  OF  JOB/EHO  OF  BATCH 

IF  PROGRAMS  >  PGMIDS  THEM  GOTO  8500 
LPRIHT  STR I MGS(80, ••*<•) 

LPRIMT 

LPRIHT  "RECORDS  PROCESSED  ...  ";SERIALS 

LPRIHT  "STARTED  AT  .  ";BTIMES 

LPRIHT  "ENDED  AT  .  ",-TIMES 

LPRIHT  CMRS(12) 

GOTO  30000 

8070  REM  CHECK  FOR  SCANNER  ERRORS 

IF  POCKETS  •  «  "  GOTO  8500 
LPRIHT  LITHOS; 

LPRIHT  "  ...  SCANNER  ERRORS  :  "; 

LPRIMT  SCANERR1S;"  /  "; 

LPRIMT  SCANERR2S;"  /  "; 

LPRINT  SCANERR3S 

LNaLNfl 

GOTO  999 

8100  REN  PRINT  THE  HEADER  VARIABLES  ON  THE  TUBE.... 

LOCATE  5,1:PRIHT  "PROGRAM  ",-PROGRAMS; 

PRINT  "  BATCH  ",-BATCHS; 

PRINT  "  RON  ";RUNI0S; 

PRINT  "  FORM  ■; FORMS; 

PRINT  "  POCKET  ";POCKETS 

GOTO  8500 

8200  REM  DECODE  THE  RESPONSE  POSITIONS 
POINTER  "  21 

RECORDPTR  »  VARPTR(SHEETREC<0)) 

FOR  J8000  -  22  TO  RECORDLENGTH 
8202  TEXTS  »  TEXTS*CHRS(PEEK(RECORDPTR  ♦  POINTER)) 

POINTER»POINTER+1 
NEXT  J8000 

8500  RETURN 


128A 

120E 

REM  --- 

.  END  OF  RXXS8C 

00. SUB  . 

128A 

120E 

128A 

120E 

9000 

REH  SINCLUDE:  ■RACS9000.SUB' 

INCLUDE  THE  SCANNER  CONTROL  SUB 

1288 

120E 

REM 

**«**« 

***** 

128B 

120E 

REM 

***• 

AMBULATORY  CARE  DATA  BASE  13  APR  85 

**** 

123B 

120E 

REM 

SKIP  COLE 

**** 

i28B 

120E 

REM 

PROGRAM  NAME 

RACS9000.SUB 

**** 

128B 

120E 

REM 

**** 

SCANNER  PROGRAM  « 

ALL 

**** 

123B 

120E 

REM 

FUNCTION 

THIS  SUBROUTINE  MODULE 

•  *** 

1288 

120E 

REH 

*«*« 

CONTROLS  THE  SCANNER  I/O 

**** 

RACP940 
SHORT  FORM 


Offset 

Data 

Source 

128B 

120E 

REM 

1288 

120E 

REM 

128B 

120E 

REM 

1288 

120E 

REM 

128B 

120E 

REM 

1288 

120E 

REM 

1288 

120E 

REM 

1288 

120E 

REM 

1288 

120E 

REM 

1288 

120E 

1288 

120E 

1288 

120E 

REM 

1288 

120E 

REM 

1288 

120E 

REM 

1288 

120E 

REM 

1288 

120E 

9001 

128C 

120E 

1293 

120E 

129A 

120E 

12A1 

120E 

12A8 

120E 

12AF 

120E 

1286 

120E 

1280 

120E 

1280 

120E 

12C9 

120E 

12D0 

1210 

12E1 

1210 

12EA 

1210 

1306 

1210 

130A 

1210 

130A 

1210 

REM 

130A 

1210 

REM 

130A 

1210 

REM 

130A 

1210 

REM 

130A 

1210 

REM 

130A 

1210 

REM 

130A 

1210 

REM 

130A 

1210 

REM 

130A 

1210 

REM 

130A 

1210 

REM 

130A 

1210 

REM 

130A 

1210 

REM 

130A 

1210 

9010 

1308 

1210 

1317 

1210 

1328 

1210 

1331 

1210 

1340 

1210 

1351 

1210 

1351 

1210 

REM 

1351 

1210 

REM 

1351 

1210 

REM 

1351 

1210 

REM 
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INPUT/OUTPUT 


MM 

REFER  TO  THE  ASYHCHROMOUS  **** 
COHMUHICATIONS  MANUAL  AND  THE  **•* 
PRE-RELEASED  SOFTWARE  GUIDE  **•* 

**** 


RESERVED  LINE 

****  NUMBERS  ;  9001-9100 

****************  A************************************************** 


•••*  SUBROUTINE  9001  -  PROTOCOL  SETUP  FOR  SCANNER  *•**• 

ARGUMENTS:  PRESET  ...  SEE  BELOW  ****• 

e****************************************************************** 


REM 

PROTOCOL(O)  ■  9600 
PROTOCOLT  1)  >  78 
PROTOCOL<2)  «  8 
PROTOCOL(3)  ■  1 
PROTOCOLIA)  >  2 
PROTOCOL (5)  a  0 
PROTOCOL(6)  a  0 

ERRSTATS  a  SPACES(60) 

ARGPTR  a  VARPTR(PROTOCOL(0)) 
CALL  SETUP  (ARGPTR, ERRSTATS) 
ERRMSGSa"" 


•BAUD  RATE 

■PARITY  (SEE  PAGE  4-8  OF  MANUAL) 

•DATA  BITS 

•STOP  BITS 

•RS-232  PORT 

•WRITE  TIME-OUT 

•READ  TIME-OUT 


IF  ASCTERRSTATS)  <>  64  THEN  ERRHSG$a»SETUP  ERROR  ■•♦ERRSTATS 
GOTO  9100 


••••  SUBROUTINE  9010  -  CONTROL  OPTIONS  FOR  SCANNER 
ARGUMENTS:  CNTRLOPT 
•••*  CHTRLOPT  a  1  «  START  SCANNER  (SI) 

***•  CNTRLOPT  a  2  a  STOP  SCANNER  (SO) 

**•*  CNTRLOPT  a  3  .  terminate  COMMUNICATIONS  TO  SCANNER  (DC3) 
**•*  CHTRLOPT  a  A  •  CLEAR  TRAHSPORT  PATH  (DC2) 

CHTRLOPT  a  5  a  SELECT  PRIMARY  STACKER  ••31" 

CNTRLOPT  a  6  a  SELECT  SECONDARY  STACKER  "32" 

CHTRLOPT  a  7  .  POSITIVE  RESPONSE/SELECT  SCANNER  (DC1) 
CNTRLOPT  a  a  a  request  STATUS  (ESC) 


REM 

ERRSTATS  a  SPACES(60) 

CALL  CNTROL  (CNTRLOPT, ERRSTATS) 

ERRMSGSa"" 

IF  ASC(ERRSTATS)  <>  64  THEM  ERRMSG$="CONTROL  ERROR  "♦ERRSTATS 
GOTO  9100 


•••*  SUBROUTINE  9020  -  SCAM  SHEET  CALL 

**** 

ARGUMENTS:  REAOTYPE 


RACP9A0 
SHORT  FORM 
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1351  1210  REM 

1351  1210  REM 

1351  1210  REM 

1351  1210  REM 

1351  1210  REM 

1351  1210  REM 

■'351  1210  REM 

1351  1210  9020 

1352  1210 

135E  1210 

1365  1210 

137E  1210 

1387  1210 

13A8  1210 

13AC  1210 

13AC  1210  REM 

13AC  1210  REM 

13AC  1210  REM 

13AC  1210  REM 

13AC  1210  REM 

13AC  1210  REM 

13AC  1210  REM 

13AC  1210  REM 

13AC  1210  REM 

13AC  1210  REM 

13AC  1210  REN 

13AC  1210  REM 

13AC  1210  REM 

13AC  1210  9030 

13AO  1210 

13B9  1210 

IjCO  1210 

1305  1216 

13F1  1216 

13F5  1216 

13F5  1216  9100  RETURN 


13F8  1216  REM  . ENO  OF  SUBROUTINE  RACS9000.SUB . 

13F8  1216 

13F8  1216  REM  END  OF  SUBROUTINES  «*»==»===»*«==«===»=====*=======*===»=========== 

13F8  1216 

13F8  1216  25000  REM  USER  TERMINATED  INPUT...  FILE  IS  NOT  TO  BE  USEDIlin 
13F9  1216  LPRINT  "USER  TERMINATED  INPUT  ..  DATA  WILL  NOT  BE  USED!" 

U01  1216  LPRINT  "ERASING  FILE  ";DATFILS 

Uf;  1216  BEEP 

U12  1216  CLS  :  PRINT  "USER  TERNINDATED  INPUT  ..  DATA  WILL  NOT  BE  USED!" 

HIE  1216  CLOSE 

1422  1216  OPEN  OATFILS  FOR  OUTPUT  AS  jFI 

H34  1216  PRINT  «1,STRINGS(RECORDLENGTH,"X")  'VOID  THE  FIRST  RECORD 

1446  1216  CLOSE 

144A  1216 

144A  1216  30000  REN 

1.4B  1216  CLOSE 

144F  1216  CHAIM  "RACP10" 

1456  1216  ENO 


************** 


****  SUBROUTINE  9030  -  TRANSPORT  PRINT  CALL 


***•  ARGUMENTS:  PRINTPOS 

•*<*  NUMERIC  VARIABLE  INDICATING  THE  STARTING  PRINT  POSITION 
••••  VALUES  ■  0  THRU  90 

•••« 

*•••  ARGUMENTS;  PSTRINCS 

•••*  TEXT  TO  BE  PRINTED  ON  THE  FORM 


NOTE;  THIS  ROUTINE  HAS  MO  EFFECT  UNLESS  THE  SCAM 
••••  HEADER  SHEET  IS  HARKED  'PRINTER  ON*  •*••• 


ERRSTATS  >  SPACES(60) 

RECORDPTR  >  VARPTR(SHEETREC(0}) 

CALL  TPR I NT(PR I NTPOS , PSTR I NGS, ERRSTATS) 

IF  ASCIERRSTATS)  <>  64  THEN  ERRMSG$°"PRINT  ERROR  "-rERRSTATS 
GOTO  9100 


READTYPE  >  2  -  REQUEST  NEW  DOCUMENT  FROM  SCANNER 
READTYPE  >  3  >  RETRANSMIT  CURRENT  DOCUMENT 

ARGUMENTS:  RECOROLENGTH 

NUMERIC  VARIABLE  SET  TO  THE  NUMBER  OF  CHARACTERS  TO  BE 
TRANSMITTED 


ERRSTATS  >  $PACES(60) 

RECORDPTR  <  VARPTR(SHEETREC(0)) 

CALL  SCAN  <REAOTYPE.R£CORDLENGTN.RECORDPTR, ERRSTATS) 
ERRMSGS-"" 

IF  M!DS(ERRSTATS,14,3)  •  "415"  THEN  ERRMSGS<*ESC" 
GOTO  9100 


RACP940 
SNORT  FORH 


Offset  Data  Source  Line 

USA  1216 
USD  1216 

221S1  Bytes  Available 
16962  Bytes  Free 

0  Warning  Error(s) 

0  Severe  Error(s) 
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*  PROCEDURE  LOADDIAG 

* 

*  LOADS  THE  DIAGNOSIS  DATA  BASE 

*  DATA  IS  IN  FILE  'DIAGNOS.DAT 

* 

* - 

FILEDEF  DIAGNOS  DISK  DIAG.RVD 
-CRTCLEAR 

MODIFY  FILE  DIAGNOS 

FIXFORM  DGNCD/C5  X2  DGNDSC/C50  X13 

MATCH  DIAG_CODE 

ON  NOMATCH  INCLUDE 
ON  MATCH  CONTINUE 
DATA  ON  DIAGNOS 
END 


1 


*  - - — ......  - i, 

*  * 

*  PROCEDURE  LOADOTH  * 

*  * 

*  LOADS  THE  OTHER  CODE  DATA  BASE  * 

*  DATA  IS  IN  FILE  'OTHER. DAT*  * 

*  * 

* - * 


FILEDEF  OTHER  DISK  C: OTHER. DAT 
-CRTCLEAR 
MODIFY  FILE  OTHER 
FIXFORM  OTHC/C5  X2  OTHDSC/C67 
MATCH  OTHER_CODE 
ON  NOMATCH  INCLUDE 
ON  MATCH  CONTINUE 
DATA  ON  OTHER 
END 


1 


* - 

* 

*  PROCEDURE  LOADPROC 

* 

*  LOADS  THE  PROCEDURE  DATA  BASE 

*  DATA  IS  IN  FILE  • PROCEDUR . DAT 

* 

* - 

FILEDEF  PROCEDUR  DISK  PROC.RVD 
-CRTCLEAR 

MODIFY  FILE  PROCEDUR 
FIXFORM  PRCCD/C5  X2  PRCDSC/C67 
MATCH  PROC_CODE 

ON  NOMATCH  INCLUDE 
ON  MATCH  CONTINUE 
DATA  ON  PROCEDUR 
END 


1 


Offset  Data  Source  Line 


PACE  1 
07-06-87 
15:11:33 

IBM  Personal  Computer  BASIC  Coirpiler  VI. 00 


0C1A 

0002 

REM  SLINESIZE: 

132 

001A 

0002 

REM  SPAGESIZE: 

66 

001A 

0002 

REM  ST  I  TIE:  'RACP050  ' 

001A 

0002 

REN  SSU8TITLE: 

■SOCIAL  WORK  SHORT  PORN 

001A 

0002 

REN  SPACE 

j 


RACP950 

SOCIAL  WORK  SHORT  FORM 
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001A  0002  REH  . . . 

001A  0002  REN  |  NANE:  RACP820  AHBULATORY  CARE  INFORMATION  SYSTEM  | 

001 A  0002  REM  j  DATE:  U  MAR  87  SOCIAL  WORK  (8FEA)  SHORT  FORM  j 

001A  0002  REN  j  D  R  BOLLING  SHORT  FORM  j 

001A  0002  REM  I  I 

001A  0002  REM  |  INCLUDES  PREFIX  TO  LITHO  FOR  EACH  PATIENT  ON  FORM  | 

001A  0002  REM  . ♦ 

001A  0002  REM  SOCIAL  WORK  SHORT  FORM  INPUT  PROGRAM 

001A  0002  REN 

001A  0002  REN  This  program  reads  the  SHORT  form  OMR  data,  converts  various 

001A  0002  REN  fields,  prints  an  error  report  and  produces  the  file: 

001A  0002  REN 

001 A  0002  REH  VI  SIT. OAT 

001A  0002  REM 

001A  0002  REM  for  input  to  FOCUS.  NOTE  THAT  THIS  FILE  IS  OPENED  FOR  APPEND 

001A  0002  REM  each  time  the  program  is  net.  Thus,  if  the  file  does  not  exist, 

001A  0002  REM  records  Mill  be  added  to  the  front.  If  the  file  exists,  records 

001A  0002  REM  will  be  addad  to  the  end  of  the  current  file.  It  is  intended  that 

001A  0002  REM  the  FOCUS  DIALOGUE  MANAGER  ROUTINE  Hhfch  loads  the  data  Mill  delete 

001A  0002  REM  the  data  file  after  the  load  has  been  successfully  accomplished. 

001A  0002  REM 

001A  0002  REH 

001A  0002  REM  If  there  is  no  valid  user  logged  at  the  time  of  execution,  this 

001A  0002  REM  program  will  chain  to  the  logon  program  RACPOS,  otherwise, 

001A  0002  REH  the  program  chains  to  program  RACP10  on  exit. 

001A  0002 

001A  0002  REH  SINCLUDE:  'RACOIH.MOO'  REH  INCLUDE  THE  DIMENSION  DEFINITIONS 

001 A  0002  ■*******«*«**«****************«********«*«*****************ik*******«*** 

001A  0002  ■*  NAME:  RACOIH.MOO  DIMENSION  DEFINITIONS  * 

)01A  0002  ■*  Oate:  28  Feb  84  Written  by:  Floyd  Cole  * 

001 A  0002  ' ********«*******•**•*•***•***««**«*•*•*•****•****«******•***««**•****• 

001A  0002  '  Dimensioned  variables  are  defined  in  this  file. 

001A  0002  ’  It  is  an  included  file  so  it  cannot  be  run  in-a  stand-alone, 

001A  0002  •  mode. 

C01A  0002  • 

001A  0002  '  This  program  segment  may  be  modified,  but  all  files  containing 

001A  0002  '  an  include  for  this  segment  must  be  re-compiled  in  order  to 

001A  0002  '  affect  the  changes  made  here. 

001A  0002  '  ••••••*•••••  START  OF  DIMENSION  OEFINITIWl  •••••••••*•••••••*•*• 

gOIA  0002 

001A  0002  OEFINT  A-Z 

0<1A  0002  DIM  USERS(2),HOLENGTH(12},DATEERRS(3) 

001A  0002 

001A  0002  ■  *••••*•*••••  end  of  DIMENSION  DEFINITIONS  ••*•••••••••••*•*•••• 

001 A  0002 

OOIA  0002 

001A  0002  REM  DIMENSION  STATEMENTS  UNIQUE  TO  THIS  PROGRAM . 

001 A  0002 

001A  0002  DIM  SHEETREC(1750)  '(MAX.  SIZE  FOR  A  SHEET  FROM  THE  SCANNER) 

001A  0002  DIN  PR0T0C0L(7)  '(ARRAY  FOR  SERIAL  BOARD  SETUP  PARAMETERS) 

001A  0002  DIM  ED.MSG$(30)  '(ERROR  MESSAGES  FROM  EDIT  ROUTINES) 

001A  0002  DIM  CLINIC2.PFX$(5)  '(PREFIX  -A  B  D  F  S-  FOR  CLINIC  #2) 

001A  0002  DIM  PROCED$(OS)  '(PROCEDURE  TABLE  FOR  SHORT  FORM) 

001A  0002  DIM  0IAG.TABS(6)  '(DIAGNOSIS  TABLE  -  PROBLEM) 
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OffMt  Data  Source  Line 
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DIM  PROVIDER. TIHES<a) 
DIM  SPECaOS(9) 

DIM  SSM.CQOS(A) 

DIM  FMP.COOS(4) 

DIM  REF.COOS(4) 

DIM  PBM.CODS(4) 

DIM  TOT.PROB<4) 

DIM  PR1.TIMS(4) 

DIM  TOT.PROC(4) 

DIM  SPE.BUFS<4) 

DIM  TOT.SPE(4) 

DIM  GROUP1S(4,06) 

DIM  HOLDS(06) 


'(PROVIDER  TIME  TABLE) 

'(SPECIFIC  PREASSIGNED  CLINIC  COOES) 


ARRAYS  TO  HOLD  MULTIPLE  VISITS 


'(PATIENT/PROCEDURE  CROUP  PROV  1) 
'(HOLD  AREA  FOR  SUBROUTINE  6000) 


REM  SINCLUDE:  ’RACCMN.MOO' 


REM  INCLUDE  THE  COMMON  AREA  DEFINITION 


NAME;  RACCMN.MOO 
Date:  28  Feb  84 


COMMON  AREA  DEFINITION 
Written  by:  Flo/d  Cole 


COMMON  AREA  DEFINITIONS  WILL  BE  HELD  IN  THIS  FILE.  IT  IS  AN 
INCLUDED  FILE  SO  IT  CANNOT  BE  RUN  IN  A  STAN0*AL0NE,  MODE. 

This  program  segment  may  be  modified,  but  all  files  containing 
an  include  for  this  segment  must  be  re*compiled  in  order  to 
affect  the  changes  made  here. 


•START  OF  COMMON  DEFINITIONS*********************®** 


COMMON  FORE, BACK, BOARD, HIDE, EFORE.EBACK.BELLS  'BASIC  SCREEN  COLORS 


COMMON  HEADERS 
COMMON  TEXTS 
COMMON  PGHIDS 
COMMON  MOLENCTHO 
COMMON  USERSO 
*************EN0 


•21  CHARACTER  SCANNER  HEADER  INFO 
"  AIMING  CHARACTERS  FROM  SCANNER 
•PROGRAM  OR  FORM  ID 
•DATS  IN  THE  MONTH 


OF  COMMON  DEFINITION* 


REM  SINCLUDE:  'RACDEF.NOO'  REM  INCLUDE  THE  DEFAULT  DEFINITIONS 


NAME:  RACP01.DEF 
Date:  28  Feb  84 


DEFAULT  DEFINITIONS 
Written  by:  Floyd  Cole 


*********************************************************** 


Variables  used  in  cannon  that  have  a  default  value  on  start*up 
will  be  held  in  this  file.  It  is  an  included  file  so  it  cannot 
be  run  in  a  stand*alone  mode.  In  normal  operation,  this  file 
should  be  'included'  in  the  main  program  only  (RACPIO.BAS). 

This  program  segment  may  be  modified,  but  all  files  containing 
an  include  for  this  segment  must  be  re*campiled  in  order  to 
affect  the  changes  made  here. 


•START  OF  DEFAULT  DEFIHITIOM********* 
'FOREGROUND  COLOR  :  INTENSE  WHITE 


RACP950 
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0050 

1022 

BACIC  >  1 

■Background  Color  •  Light  Blue 

0057 

1022 

BORO  *  4 

•BORDER  *  RED 

005E 

1024 

HIDE  >  4 

•ALTERNATE  COLOR  *  RED 

0065 

1024 

EFORE"  14 

•ERROR 

FOREGROUND  DISPLAY 

006C 

1024 

EBACK"  0 

•ERROR  BACKGROUND  DISPLAY 

0073 

1024 

BELLS  >  CHRS(7) 

■Sound  the  bell 

'X)7F 

1024 

007F 

1024 

HOLENGTH(I) 

m 

31 

•JAN 

0086 

1024 

NOLENGTH<2) 

M 

28 

•FEB  <— MODIFIED  IN  SUBROUTINE  RACSSOOO. 

0080 

1024 

MOLENGTH(3) 

u 

31 

•MAR 

0094 

1024 

NOLENGTH(4) 

u 

30 

■APR 

009B 

1024 

NOLENGTH<5} 

m 

31 

•MAY 

00A2 

1024 

M0LENGTH(6) 

u 

30 

•JUN 

OOA9 

1024 

N0LENGTH(7) 

m 

31 

•JUL 

0080 

1024 

M0LENGTH(8) 

m 

31 

•AUG 

0087 

1024 

H0LENGTH(9) 

M 

30 

•SEP 

OOBE 

1024 

MOLENGTHdO) 

m 

31 

•OCT 

00C5 

1024 

MOLENGTH(II) 

m 

30 

•NOV 

OOCC 

1024 

MOLENGTH(12) 

m 

31 

•DEC 

'003 

1024 

0003 

1024 

DATEERRS(O) 

9 

■  N 

OOOC 

1024 

OATEERRSd) 

M 

■INVALID  MONTH" 

00E5 

1024 

0ATEERR$(2) 

9 

■IHVALIO  DAY  • 

OOEE 

1024 

0ATEERRS(3) 

9 

"DAY 

TOO  LARGE  FOR  MONTH  COOED" 

OOF7 

1024 

00F7 

1024 

HAXLENGTH 

9 

80 

•MAXIMUM  LENGTH  OF  OUTPUT  RECORD 

OOFE 

1026 

PADS 

s 

•PAD  CHARACTER  FOR  SHORT  RECORDS 

0107 

102A 

0107 

102A 

1  •••.•******..E)n,  Qp 

DE  FAULT  DE  F I  HI  T  ION"*"""***"""*****"***"** 

0107 

102A 

0107 

102A 

'107 

102A 

KEY  OFF 

0100 

102A 

0100  102a  REM  «*«******«***^*****«^****************»************************ 

010O  102A  REM  THE  FOLLOUIHG  VARIABLES  ARE  UHIQUE  TO  EACH  PROGRAM  AMD  MUST 

0100  102A  REN  BE  CHANGED. 

0100  102a  REN  ********♦******•♦*♦***♦****••***♦*♦******♦*•♦♦***************♦* 

0100  102A  PGNTITLS  «  "SOCIAL  WORK  (BFEA)  SHORT  FORM" 

0116  102E 

0116  102E  PGMIDS  s  "950"  'VALUE  RECEIVED  FROM  THE  SCANNER 

011F  102E  'IN  HEADER  VARIABLE  'PROGRAMS' 

011F  102E 

011F  102E  DATFILS  »  "VISIT.OAT"  'FILE  TO  BE  INPUT  TO  FOCUS 

0128  1032 

0128  1032  REM  LENGTH  OF  STRING  RECEIVED  FRON  THE  OMR.... 

0128  1032  HEADER  »  21 

012F  1034  RESPONSE*  162 

0136  1036  RECOROLENGTH  =  HEADER  *  RESPOHSE 

OKI  1038 

0141  1038  H.PROC  =  05  '  HUMBER  OF  PROCEDURES  FOR  THIS  FORM 

0148  103A 

0148  103A  REM 

0148  103A 

0148  103A  8TIME$=TIME$  'SCAM  START  TIME 
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0151  103E 
0151  103E 
0151  103E 
0151  103E 
015A  103E 
0163  103E 
016C  103E 
0175  103E 
017E  103E 
0187  103E 
0187  103E 
0187  103E 
01A2  103E 
01BO  103E 
01BD  103E 
01BO  103E 
01CF  103E 
01E1  103E 
01F3  103E 
01 FC  103E 
01 FC  103E 
01  FC  103E 
0205  103E 
Q2QE  103E 
0217  103E 
0220  103E 
0229  103E 
0232  103E 
023B  103E 
0244  103E 
0240  103E 
0240  103E 
0240  103E 
0240  103E 
0240  103E 


REM  ***  ENCOUNTER  FORM  CLINIC  PREFIX  TABLE  •** 

REN  CLINIC  #2 

CLINIC2.PFXS(0)>-  ■ 

CL1NIC2.PFXS(1)>''A" 

CL1NIC2.PFXS(2)>"B" 

CLINIC2.PFXS(3)-"0" 

CLINIC2.PFXS(4)>'<F<* 

CL1NIC2.PFXS(3)»'‘S“ 

REM  •**  ENCOUNTER  FORM  PROCEDURE  TABLE  *** 

PROCEDS(0)>"  "  :  PROCEDS<02)  «  "02404“  :  PROC£0S(04)«  "02413“ 
PROCEDS(1)«“03010"  :  PROCE0S(03)  »  “02412"  :  PROCED$(05)«  “90601“ 

REM  PROBLEM  -OX  TABLE  *•* 

0IAG.TABS<0)>“  “  :  DIAG.TABS(3)«“S2104“ 

OIAG.TABS(1}>“S2159»  :  0IAG.TABS(4)«“$2266“ 

DIAG.TABS(2)«"S2296“  :  DIAG.TABS(5)«“S2297“ 

0IAG.TABS(6)>“S21O9“ 

REM  *•*  PROVIDER  TIME  TABLE  *“• 

PROVIDER. TIME$(00)»"000“  •  NO  TIME 

PROVIDER. TIMES<01)«“005“  '  5  MINUTES 

PROVIDER. TIMES(02)a“010“  *10  MINUTES 

PROVIDER. TINE$<03)>"01S"  *15  MINUTES 

PROVIDER.TIMES(04)>“020"  <20  MINUTES 

PROVIDER. TIHES(0S)>“030"  <30  MINUTES 

PROVIDER. TINE$(06)>"040“  <40  MINUTES 

PROVIDER. TIME$(07)=''050"  <50  MINUTES 

PROVIDER. TmES(08)«"060<'  <  1  HOURS 


REN  INCLUDE:  'UCABAMC.OPT'  INCLUDE  OUTPATIENT  UCA  TABLE 
REN  SPAGE 
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GOSUB  1000 
CLS 

GOSUB  7000 


•HAKE  SURE  THEY  ARE  LOGGED  ON 


•PRINT  SCREEN  HEADING 


OPEN  FILE  TO  CONTAIN  SCANNED  DATA 


OPEN  OATFILS  FOR  APPEND  AS  #1 


***•  CLEAR  AND  DISPLAY  PROGRAM  SCREEN  •*** 

■*>>******»•**•*****»**»»»»*•««••**< ■«»>******« 

LPRINT  CHRS(IS); 

WIDTH  ■LPT1;",160 

PAGE  ■  0  :  GOSUB  7100  'LINE  PRINTER  HEADING 
COLOR  14 

LOCATE  11.26  :  PRINT  "SOCIAL  WORK  SHORT  FORM" 

COLOR  FORE.BACK.BORO 


Hgfll  **«*****M*****«*****M**M**************<*«***«****M*****«M***** 

HEM  •***  COMMUNICATIONS  SETUP 

REM  •*•••*••••••*•***•*•••*•*••***•••*•**••*«••«*•*•••«*• 

REM  PROTOCOL 
GOSU8  9001 

IF  ERRMSGS  >  "  «  THEN  LPRINT  ERRMSGS  :  GOTO  30000 


*"*•  COMMUNICATIONS  SETUP 

•*•••*••••••*•***•*•••*•*••**••••*•**••*«••«*•*•••«*•*•*••*•*•**••* 


REM  START  SCANNER  (SI) 

CNTRLOPT  =1  :GOSUB  9010 

IF  ERRMSGS  >  «  >  THEN  LPRINT  ERRMSGS  :  GOTO  30000 

LOCATE  22,25:PRINT  "PRESS  'ESC  TO  TERMINATE  SCANNING  ■ 
REA0TYPE:3  'FIRST  TIME  IN..  SCANNER  IS  STARTED.. 


•***  SET  SCAN  SHEET  CALL  **** 

•******«***************«*********«******w****«*******«************* 


10  REN  -  RETURN  POINT  TO  READ  NEXT  SHEET 
AS> INKEYS 

IF  A$>CHRS(27)  THEN  GOTO  25000 


GOSUB  9020 


■SCAN  SUBROUTINE  -  GET  A  RECORD 


IF  MI0$(ERRSTAT$,14,3)="415"  THEN  GOTO  25000 


TEXTS*”"  'CLEAR  THE  INPUT  AREA 

GOSUB  8000  'DECODE  HEADER 

GOSUB  8050  'CHECK  FOR  END  OF  JOB/END  OF  BATCH 

GOSUB  8200  'DECODE  THE  RESPONSE  POSITIONS 

LITHOS  *  HIDS(TEXTS,22,8) 

GOSUB  8070  'CHECK  FOR  SCANNER  ERRORS 
GOSUB  8100  'PRINT  THE  DATA  ON  THE  SCREEN 


IUCP950 

SOCIAL  UORK  SHORT  FORM 


PAGE  7 
07-06-87 
15:11:33 

OffMt  Data  Sourca  Lina  IBM  Paraonal  Coiputar  BASIC  ConpUer  VI. 00 


0396  1054 
0396  1054 
0396  1054 
0396  1054 
0396  1054 
0396  1054 
0396  1054 
0396  1054 
0396  1054 
0396  1054 
0396  1054 
0396  1054 
0396  1054 
0396  1054 
0396  1054 
039D  1056 
039D  1056 
0390  1056 
0390  1056 
0390  1056 
03A6  105A 
03A6  105 A 
03A6  105A 
0388  105E 
03CA  1062 
030C  1066 
03F1  1066 
0411  1066 
041F  106A 
0431  106E 
0443  1072 
0471  1074 
049F  1074 
049F  1074 
04A8  1078 
04AO  1078 
0486  107C 
04BB  107C 
04DF  107E 
04E7  107E 
0500  107E 
0500  107E 
0500  107E 
051F  1082 
0531  1086 
053F  lOSA 
053F  108A 
0546  108C 
0540  108E 
0554  1090 
055B  1092 
0562  1094 
0569  1096 
0570  1098 


N.ERR  >0  'COUNTS  THE  NUMBER  OF  ERRORS 

REM  •••  LITHO  COOE  DONE  IN  BAS  PROGRAM 

REM  CLINIC  10  *•* 

100  CL1.CaOS-''BFEA''  'DEFAULT  CLINIC  COOE 

REM  VISIT  DATE  •** 

102  CMS«M1DS(0ATES,1,2)  'CURRENT  MONTH 

TRS>M10S(DATES,9,2)  'CURRENT  TEAR 

XS*MI0S(TEXTS,31,4)  'MONTH  AND  OAT  FROM  FORM 

IF  LEFT$<X$,2)«CM$  THEN  104  'OK,  USE  THIS  TEAR 

YR$»RIGHT$(STRS(VAL(TRS)-1),2)  'USE  UST  TEAR 

104  VOATES  >  TRS  ♦  X$ 

01S>HI0S(XS,3,1) 

02$«MI0S(X$,4,1) 

IF  01$»"  "  ANO  OESo"  «  THEN  RT.5000»2  ;  GOTO  105 
IF  OISo"  ■  AND  OES*"  "  THEN  RT. 5000-2  :  GOTO  105 
'EDIT  VISIT  DATE 

CK.5000S-VOATES 

GOSUB  5000  'DATE  CHECK 

CK.5010S- VOATES 

GOSUB  5010  'NUMERIC  STRING  CHECK 

IF  RT.5000  ■  0  ANO  RT.5010  ■  0  THEN  GOTO  106 

105  N.ERR-N.ERR+1 

EO.MSGS<N.ERR)»''TOOATS  DATE  "  ♦  OATEERR$(RT.5000) 

REM  PROVIDER  1  ID  (PREFIX  ♦  NUM)  ••• 

106  PROV1.PFXS  -  MIDS(TEXTS,35,1) 

PROVI.NUMS  -  MIDS(TEXTS,36,4) 

PRI.COOS-PROVI.PFXS  ♦  PROVI.NUMS 


SSN.OFFSET  >  40 
FMP. OFFSET  -  49 
RPF. OFFSET  «  51 
REF. OFFSET  >  52 
TIM.OFFSET  »  55 
UPR. OFFSET  *  56 
PBM. OFFSET  «  61 
PRC. OFFSET  -  62 


I 
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Offset 

Oats 

Source  Line 

0577 

109A 

SPE.OFFSCT  •  67 

057E 

109C 

TOT. 

OFFSET  ■  36 

0585 

109E 

POINTER  ■  0 

'58C 

10A0 

058C 

10A0 

058C 

10A0 

REH 

•**  REPEAT  THE  FOLLOWING  CODE  4  TIMES 

058C 

10A0 

FOR  1910-  1  TO  4 

1'593 

10AO 

0593 

10A0 

REM 

SSN  AND  FMP 

0593 

10A0 

110 

SSN.COOS<I910)<MIDS(TEXTS,SSN.OFFS£T«POINTER.9) 

05B6 

10A2 

FMP.CaOS(I910)-MIOS<TEXTS,FNP.OFFSET^tNTER,2) 

0509 

10A2 

REM  BYPASS  IF  NO  SSN  OR  FMP  FOR  THIS  PART 

0509 

10A2 

IF  SSN.CQO$(I910)+FMP.COOS(I910)-STRINGS(11.*  -)  THEN  136 

0606 

10A2 

0606 

10A2 

REN 

***  REFERRAL  CODE  *•* 

0606 

10A2 

112 

X>VAL(MIDS(TEXTS,RPF.OFFSET4^POINTER.1)) 

.621 

10A4 

REF.COOS(I910)-CLINIC2.PFXS(X)*MIDS(TEXTS,REF.OFFSET«POINTER, 

0655 

10A4 

0655 

10A4 

REM 

TIME  SPENT  •** 

0655 

10A4 

114 

X=VAL (HI D$<TEXT$, T IM . OF  FSET+POI NTER , 1 ) ) 

0670 

10a4 

PR1.TIMS(I910)-PROVIDER.TIHES(X) 

0680 

10a4 

IF  PR1.TIM$<I910)<>"000"  THEN  116  'GO  IF  THERE  IS  A  TIME 

06A5 

10A4 

N.ERR-N.ERR+1 

06AD 

10A4 

ED.MSGS(N.ERR)>"NO  TIME  COOED  FOR  PART  ".f$TR$(I910) 

06CA 

10A4 

06CA 

10A4 

REN 

ADDITIONAL  PROCEDURE 

06CA 

10a4 

116 

ADDPS:M1IDS(TEXTS,UPR.OFFSET«POINTER,S) 

06E1 

10a8 

r6£1 

10a8 

REN 

•••  PROBLEM 

(j6£1 

10A8 

118 

X  »  VAL<MIDt(TEXT$,PBM.OFFSET*POINTER,1)) 

06FC 

10A8 

PBM . COOS( I 91 0 )-0 I AG . T AB$(X) 

0719 

10A8 

0719 

10A8 

REN 

PROCEDURE  COOES  FOR  PROV  1  ••• 

0719 

10A8 

120 

X$  »  MID${TEXT$,PRC.OFFSET+POIMTER,M.PROC) 

0731 

10A8 

GOSUB  6000  'DECODE  THE  XS  STRING 

0736 

10A8 

IF  TOT  »  0  THEM  GOTO  122 

0745 

IOAA 

FOR  1910. A-  1  TO  TOT 

0752 

IQAC 

PTR-VAL(HOLO$(I910.A)) 

0768 

1080 

CR00P1$<I910, I910.A)«PROCEOS(PTR) 

078A 

10BO 

NEXT  1910. A 

0798 

IOBO 

O'l-VB 

10B0 

REH 

...  ADD  UNLISTED  CODE  IF  THERE  TO  PROV  1  ... 

0798 

IOBO 

122 

IF  ADDPS-"  "  THEN  124 

07A9 

IOBO 

TOT-TOT+1 

07B1 

IOBO 

GROUP1S(I910,TOT)=AOOP$ 

07CA 

IOBO 

07CA 

IOBO 

124 

TOT.PROC(I910)=TOT 

0709 

1080 

0709 

IOBO 

REM 

•••  SPECIFIC  PREASSIGNEO  CL  COOES  ••• 

07D9 

1080 

126 

INP.STO$=MIO${ TEXTS, SPE.0FFSET+P0INTER,9) 

07F0 

10B4 

GOSUB  5700  'CONVERT  ARRAY 

07F5 

10B4 

SPE.BUF$(I910)=BUF.STO$  'UP  TO  9  TWO  DIGIT  COOES 

0809 

loss 

OSfT 

10B8 

130 

POINTER  =  POINTER  ♦  TOT. OFFSET 
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0814  10B8  136  NEXT  1910 

0826  10B8  199  REM 

0827  1088 

0827  10B8  REM . END  OF  MODULE  RXXM950.MO1 . 

0827  1088 

0827  10B8 

0827  10B8  IF  N.ERR  «  0  THEN  GOTO  997 

0836  10B8  LPRINT  "LITHO  #  “;LITHOS;«  ...ERRORS" 

0848  10B8  FOR  1997  •  1  TO  N.ERR 

0855  108A  LPRINT  USING  “FWR  ••;t997; 

0861  108C  LPRINT  "«»>  ";E0.MSGS(I997) 

0877  10BC  NEXT  1997 

0888  10BC  LN. COUNT  >  LN. COUNT  *  N.ERR  »  1 

0894  10BE  CNTRLOPT  «  6 

0899  10BE  GOSUB  9010  'REJECT  THE  FORM 

08A0  10BE  GOTO  998  'BYPASS  THE  DISK  WRITER _ 

08A4  10BE 

08A4  10BE  997  REM  SINCLUDE:  'RACM950.H02'  REN  INCLUDE  THE  BASE  ENCOUNTER  FORM  DISK  WRITER 
08A5  10BE  REM  *****************«*****«««*********«*4««fH»**********«**«««*«*«*#«*« 


08AS 

10BE 

REN 

***« 

AMBULATORY  CARE  INFORMATION  SYSTEM  14  MAR  87 

*«** 

08AS 

108E 

REM 

D  R  BOLLING 

08AS 

10BE 

REM 

*««• 

MODULE  NAME  : 

RACN9S0.NO2 

08A5 

10BE 

REM 

«««* 

SCANNER  PROGRAM  «  ; 

950-  SOCIAL  WORK  SHORT  FORM 

08AS 

10BE 

REM 

•«*« 

08A5 

10BE 

REM 

PURPOSE  : 

CREATE  AND  WRITE  THE  DISK 

•••• 

08A5 

10BE 

REM 

RECORD  FOR  INPUT  TO  FOCUS 

08A5 

108E 

REM 

***• 

08A5 

10BE 

REM 

PROGRAM  ADOS  PREFIX  TO  LITHO  FOR  EACH  PATIENT 

08AS 

10BE 

REM 

08A5 

10BE 

REM 

RESERVED  LINE  NUMBERS  200-299 

08A5 

10BE 

REM 

08A5 

10BE 

08AS 

10BE 

REM 

BUILD 

THE  OUTPUT  RECORD 

08A5 

10BE 

08AS 

108E 

GOSUB 

270  'BUILD 

THE  RECORD  KEY 

08AA 

10BE 

08AA 

10BE 

REM 

08AA 

10BE 

REM 

RECORD  TYPE  "1"  -  RECKEY 

PLUS  DATA  AND  DX1  CODE 

**** 

08AA 

10BE 

REM 

08AA 

10BE 

08AA 

10BE 

FOR  1950  «  1  TO  4 

0881 

10BE 

RECOUTS  «  "9501“  ♦  RECKEYS 

'INITIALIZE 

08BF 

10C6 

PTtOS= 

=SSN.COOS(I950>+FMP.COOS(I950) 

080E 

10CC 

IF  PTID$=STRING$(11,"  ")  THEN  248 

'NO  MORE  TO  DO  IF  BLANK 

08F3 

10CC 

RECOUTS=RECOUT$*R I GHT$(STR$( 1950) , 1 )+R I GHTS(L I THOS, 7) 

0918 

10CC 

MI 0$( RECOUTS , 20 , 1 1 )=PT I 0$ 

0927 

10CC 

RECOUTS  =  RECOUTS  ♦  "95" 

'ADO  FORM  NUMBER 

0933 

10CC 

0933 

10CC 

RECOOIS^"" 

'INITIALIZE 

093C 

1000 

093C 

1000 

REN 

**•  VISIT  COUNT 

093C 

10O0 

REC001S*REC001S+"1" 

0948 

1000 

0948 

1000 

REM 

TIME  PROV1 

< 

R  CP950 
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Offset 

D«ta 

Source  Line  IBM  Personal  Conputer  BASIC  Compiler  VI. 00 

L' 

09A8 

1000 

RECa01S>REC00lS«PR1 .T IMS( 1950) 

0950 

1000 

i 

0950 

10D0 

REM 

**•  SEC  PROV  -  SEC  PROV  TIME  -  SEC  PROV  REAS  -APP  STAT 

0950 

1000 

RECOOISaRECOOIS+STRINGSdO,"  *) 

■ 

096F 

1000 

■ 

096F 

1000 

REM 

**•  REFERRAL  COOE  *** 

■ 

096F 

1000 

RECa01S>RECa01»»REF.Ca0S( 1950) 

■ 

0984 

1000 

■ 

.984 

1000 

REN 

***  REMAINING  AREA  FILL 

■ 

0984 

1000 

RECC01$*REC001S+STRINGS(11.>  ••) 

0996 

1000 

0996 

1000 

REN 

PRIM  OX  ••• 

0996 

1000 

RECt»1SsRECQ01S«PBM.CQDS( 1950) 

09AB 

1000 

REC0UTS«REC0UTS+RECQ01S 

0987 

10D0 

GOSUB  280 

i 

09BC 

1000 

PRINT  «1, RECOUTS 

■ 

.09C7 

1000 

09C7 

1000 

NEXT  1950 

0909 

1000 

0909 

1000 

248 

REM  END  OF  TYPE  1  RECORO  PRKESSING 

C90A 

1000 

_  U90A 

1000 

REM 

«*«««*«*tr************»***»***«»*»**«****s»«*******«***«*«****««*»*«« 

1 

f  •  09DA 

1000 

REN 

*•••  RECORD  TYPE  "2"  -  RECKEY  PLUS  PROCEDURE  COOE 

090A 

1000 

REM 

C90A 

1000 

REM 

RECOUTS  «“9502"-»RECKEYS  ‘TRANSACTION  IDENTIFIER 

090A 

1000 

090A 

10D0 

FOR  1950  »  1  TO  4 

09E1 

1000 

PT I D$=SSM .COOS( I 950 )+FMP , COOSl 1950 ) 

1 

OAOO 

1000 

IF 

PriDS=STRING$<11,"  ")  THEN  251  'NO  MORE  TO  00  IF  BLANK 

■ 

0A15 

1000 

FOR  I910.A  =  1  TO  TOT. PROCC 1950) 

0A29 

1002 

RECOUTS  *  "9502«  ♦  RECKEYS  ♦  RIGHT$<STR${I950),1)  *  RIGHTS(LITHO$, 7)  1 

(■.*59 

1002 

NIOS<RECOUT$,20, 1 1 )=PTIOS 

0A68 

1002 

RECOUTS  *  RECOUTS  •*■  "95"  'ADD  FORM  NUMBER 

0A74 

1002 

RECOUTS  sRECOUTS  ♦  "1"  ♦  GROUP1SU950,I9iO.A> 

■ 

0A98 

1002 

GOSUB  280 

i 

0A9O 

1002 

PRINT  #1, RECOUTS 

0AA8 

1002 

NEXT  I910.A 

OABC 

1002 

250 

NEXT  1950 

OACE 

1002 

OACE 

1002 

251 

REM  END  OF  TYPE  2  RECORO  PROCESSING 

OACF 

1002 

i 

OACF 

1002 

REM 

OACF 

1002 

REN 

RECORD  TYPE  "3"  -  RECKEY  PLUS  SPEC  PRE  CLINIC  CODES  •••• 

OAf  F 

1002 

REM 

OACF 

1002 

FOR  1950  -  1  TO  4 

0AD6 

1002 

PTI0S*SSN  .COOS{  I950)-»FMP.C00S(  1950) 

0AF5 

1002 

IF  PTlO$=SrRIMG$(11,"  ")  THEM  256  'NO  MORE  TO  00  IF  BLANK 

■ 

OBCA 

1002 

IF  LEN(SPE.BUFS(I950))=0  THEN  254 

r 

0820 

1002 

RPOIMT=1 

0927 

1004 

252 

REC003S=RIGHTS(MIDS(SPE.BUFS(I950),RPOINT,2),1) 

0B49 

1008 

IF  REC003S="  "  THEN  253 

C957 

1008 

RECOUTS  =  "9503"  ♦  RECKEYS  ♦  RIGHTS<STRS{I950),1)  RIGHTS(LITH0S,7) 

0B87 

1008 

M I 0S( RECOUTS, 20, 1 1 >=PTIDS 

■ 

0396 

1008 

RECOUTS  s  RECOUTS  ♦  «95"  *ADO  FORM  NUMBER 

1 

IUCP9S0 
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08A2 

looa 

RECOUTS  >RECOUT$  *  REC003S 

08AE 

1008 

GOSUB  280 

0BB3 

1008 

PRINT  #1, RECOUTS 

OBBE 

1008 

OBBE 

1008 

253 

RPOINT  »  RPOINT  ♦  2 

0BC7 

1008 

IF  RPOINT  <  LEN(SPE.BUFS(I9S0))  THEN 

252 

OBOF 

1008 

08OF 

1008 

254 

NEXT  1950 

0BF1 

1008 

0BF1 

1008 

256 

REM  END  OF  TYPE  3  RECORDS 

08F2 

1008 

0BF2 

1008 

GOTO  299 

0BF6 

1008 

0BF6 

1008 

REM 

A************************#*##*******! 

0BF6 

1008 

REM 

SUBROUTINE  270  •  BUILD  THE  RECORD  KEY 

0BF6 

1008 

REM 

0BF6 

1008 

270 

RECKEY$«““ 

OBFF 

1008 

OBFF 

1008 

REM 

**•  CLINIC  10  (PREFIX  ♦  CODE)  ••• 

OBFF 

1008 

RECKEYS>  CLI.COOS 

ocoa 

1008 

ocoa 

1008 

REM 

*•*  VISIT  DATE  •** 

ocoa 

1008 

RECKEYS«RECKEY$r  VDATES 

ocu 

1008 

OCH 

1008 

REM 

PROVIDER  10  (PREFIX  ♦  NUM)  ••• 

ocu 

1008 

RECKEYS  >  RECKEYS  *  PRI.COOS 

0C20 

1008 

0C20 

1008 

REM 

PATIENT  ID  (SSN+FMP)  ••• 

0C20 

1008 

RECKEYS  «  RECKEYS  ♦  STRINGS(11,"  ") 

0C32 

1008 

0C32 

1008 

REM 

LITHO  CODE  **• 

CC32 

1008 

REM 

DO  LITHO  IN  LOOP  ABOVE 

0C32 

1008 

REM 

RECKEYS  «  RECKEYS  ♦  LITHOS 

0C32 

1008 

0C32 

1008 

RETURN 

0C35 

1008 

0C35 

1008 

REM 

0C35 

1008 

REM 

••••  SUBROUTINE  280  -  PAD  THE  RECORD 

TO  MAXLENGTH 

0C35 

1008 

REM 

****«•*•***«****«*««•'*•*«*••«««••*«**«*««*«*«•*«•« 

0C35 

1008 

280 

PAO-MAXLENGTH  -  LEN(RECQUTS)  'FIND  OUT  HOH  SH(»T 

0C43 

100A 

RECOUTS  °  RECOUTS  «  STRINGS! PAD, PADS) 

■PAD  THE  RECOR 

0C56 

100  A 

RETURN 

0C59 

100  A 

0C59 

100A 

0C59 

100A 

299  REM 

OCSA 

100A 

OCSA 

100A 

REM 

0C5A 

100  A 

OCSA 

10OA 

998 

REM  CONTINUE 

OCSB 

100  A 

ocsa 

100A 

999 

REAOTYPE  «  2 

0C62 

100  A 

IF  LN. COUNT  >  48  THEN  GOSUB  7100 

■PRINTER  HEAD 

0C72 

100A 

GOTO  10 

0C76 

10DA 
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0C76  100A  REM  END  OF  SCAN/OECOOE/WRITE  LOOP  »=sa.M«s=»a========»======«=x=a=:===== 

0C76  100A 

0C76  100A  1000  REM  SIHCLUDE:  'RACS 1000. SUB*  INCLUDE  THE  VERIFY  LOGON  SUB 


0C77  100A  REH  ******************************'»*****«>*»o*t»**o*******o*****»**»»»»** 

0C77  10DA  REM  *  NAME:  RACS1000  LOGON  VERIFICATION  SUBROUTINE  * 
0C77  100A  REM  *  Date:  28  Feb  84  PATIENT  REGISTRATION  PROGRAM  * 
0C77  100A  REN  ***eee**e************x****************************x***************x** 
0C77  10DA  REM  PATIENT  OMR  INPUT  PROGRAM  * 
0C77  100 A  REM  • 


0C77  100A  REM  This  program  verifies  user  is  logged  on  properly.  If  there  is  no 

0C77  100A  REM  valid  user  logged  on  at  the  time  of  execution,  this  subroutine  will 

0C77  100A  REM  chain  to  the  logon  program  RACP05,  otherwise  a  return  is  issued. 

0C77  100 A  REM  ******************************************************************** 

0C77  100A  REM  RESERVED  LINE  NUMBERS  ARE  1001  THRU  1010 

0C77  100A  REM  ******************************************************************** 

0C77  100A  1001  OPEN  “I“,1,”RACL0G.0AT" 

0C89  100A  IF  EOF(1)  THEN  1002  'MAKE  THEM  LOG  ON  FIRST 

0C97  100A  INPUT  «1 ,USERS(1 ),0T$,TM$,PID$ 

0CB8  10E6  IF  USERS(I)  >  ««  THEN  1002  'MAKE  THEN  LOG  ON  FIRST 

0CC6  10E6  IF  USERSd)  «  «****••••  THEN  1002  ‘MAICE  THEM  LOG  ON  FIRST 

0C04  10E6  CLOSE  1 

OCOB  10E6  SCREEN  0,1, 0,0 

0CF1  10E6  COLOR  FORE ,  BACK ,  BORO 

0007  10E6  CLS 

OOOB  10E6  RETURN 

OOE  10E6 

OOOE  10E6  1002  CLOSE 

0012  10E6  CHAIN  "RACPOS" 


0019 

1019 

10E6 

10E6 

3XXX==xEN[ 

OF  LOGON  VERIFY  SUB 

ROUT  I NE  1000=x==============*===== 

0019 

10E6 

2000 

REM  tINCLUDE:  ■ RACS2000 . SUB > 

INCLUDE  THE  REPLY/DELAY  SUB 

0C1A 

10E6 

REN 

ft**** 

001A 

1026 

REM 

AMBULATORY  CARE  OATA 

BASE  13  APR  85 

0O1A 

10E5 

REM 

*«*• 

SKIP  COLE 

•’*** 

001A 

10E6 

REM 

SUBROUTINE  NAME 

:  RACS2000.SUB 

«**« 

001A 

10E6 

REM 

SCANNER  PROGRAM  « 

;  ALL 

**«* 

r  lA 

10E6 

REM 

•  *«« 

FUNCTION 

:  THIS  SUBROUTINE  MODULE 

0O1A 

10E6 

REM 

**«* 

SERVERS  AS  A  WAIT  AND  REPLY 

**** 

0O1A 

10E6 

REM 

***« 

ENTRY  MODULE 

•  *** 

0O1A 

10E6 

REM 

*«** 

INPUT 

:  SINGLE  KEYBOARD  ENTRY 

00 1A 

10E6 

REM 

**** 

001A 

10E6 

REM 

OUTPUT 

:  KEYBOARD  ENTRY  -  UPPER  CASE 

**♦* 

001A 

10E6 

REM 

001A 

10E6 

REM 

**«* 

RESERVED  LINE 

«•** 

001A 

10E6 

REM 

**** 

NUMBERS 

:  2001-2010 

*«** 

001A 

10E6 

REM 

**«*«**1 

001A 

10E6 

2001 

REM  REPLY  FUNCTION 

0O1B 

10E6 

2002 

REPLYSx INKEYS  :  IF  REPLYS="" 

THEN  2002 

00?F 

10EA 

REPLY=ASC(REPLY$) 

00o9 

10EC 

IF  REPLY 

>  90  THEN  REPLYS=CHR$<R£PLY  XOfi  32)  'CONVERT  TO  CAPS 

0054 

10EC 

IF  REPLYS  <  "A"  OR  REPLYI  >  ' 

Z"  THEN  REPLYSx"?" 

0080 

10EC 

RETURN 

0D83 

10EC 

0033 

10EC 

5000 

REM  SINCLUOE:  ’RACS5000.SUB' 

INCLUDE  THE  DATE  EDITOR  SUB 
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0084 

10EC 

REM 

**«««******«***•********«**««***«*««*««*««**•******••******««*««•*• 

0084 

10EC 

REM 

**** 

AMBULATORY  CARE  DATA  BASE  13  APR  85 

**«• 

0084 

10EC 

REM 

SKIP  COLE 

**** 

0084 

10EC 

REM 

*«*« 

SUBROUTINE  NAME  : 

RXXSSOOO.SUB 

***« 

0084 

10EC 

REM 

SCANNER  PROGRAM  #  : 

ALL 

0084 

10EC 

REM 

FUNCTION  : 

THIS  SUBROUTINE  MODULE 

•*** 

0084 

10EC 

REM 

**«« 

PERFORMS  A  DATE  EDIT 

0084 

10EC 

REM 

•**« 

0084 

10EC 

REM 

INPUT  : 

DATE  TO  BE  CHECKED  MUST  BE 

*«** 

0084 

10EC 

REM 

•••« 

IN  THE  VARIABLE  NAMED 

0084 

10EC 

REM 

*•** 

•CK.5000$' 

0084 

10EC 

REM 

***« 

IN  THE  FORMAT  “TYMMOD" 

**«* 

0084 

10EC 

REM 

**** 

**«• 

0084 

10EC 

REM 

***« 

OUTPUT  : 

•RT.5000'  IS  THE  RETURN  CODE 

0084 

10EC 

REM 

**«• 

VARIABLE.  IF  THIS  VARIABLE 

0084 

10EC 

REM 

«**« 

CONTAINS  ANY  NUMBER  OTHER 

**** 

0084 

10EC 

REM 

**•« 

THAN  0,  AN  ERROR  WAS  FOUND 

*««* 

0084 

10EC 

REM 

***« 

IN  THE  DATE. 

••*« 

0084 

10EC 

REM 

**** 

0084 

10EC 

REM 

RESERVED  LINE 

***« 

0084 

10EC 

REM 

*««* 

NUMBERS  : 

5001-5009 

*«** 

0084 

10EC 

REM 

•«««•««««««*•**•**•*****«***«**«♦**«**«***•**«*****«#********•*•**• 

0084 

10EC 

RT.5000  *  0 

0088 

10EC 

CKYEAR  »  VAL<LEFT$(CIC.5000$,2))  ’YEAR  NUMERIC  VALUE 

009E 

10EE 

CKMONTH  3  VAL(MI0$(CK.5000S,3,2))  'MONTH  NUMERIC  VALUE 

0084 

10F0 

CKDAY  «  VAL{RIGHTS<CK.5000$,2))  'OAY  NUMERIC  VALUE 

0OC7 

10F2 

OOC7 

10F2 

IF  CKMONTH  <  1  THEN  RT, 5000*1  !  GOTO  5009 

0000 

10F2 

IF  CKMONTH  >  12  THEN  RT.5000 

=1  :  GOTO  5009 

OOF3 

10F2 

IF  CKDAY  <  1  THEN  RT. 5000*2  :  GOTO  5009 

0E09 

10F2 

IF  CKDAY  >  31  THEN  RT.5000 

*2  :  GOTO  5009 

0E1F 

10F2 

0E1F 

10F2 

REM 

LEAP  YEAR  CHECK 

0E1F 

10F2 

MOLENGTH{2)  =  28 

0E26 

10F2 

IF  CKMONTHo  2  THEN  GOTO  5005  'MUST  BE  FEBRUARY 

0E35 

10F2 

IF  (CKYEAR  MOO  4)  <>  0  THEN  GOTO  5005  'MUST  BE  A  LEAP  YEAR 

0E4A 

10F2 

MOLENGTH(2)  *  29 

0E51 

10F2 

0E51 

10F2 

5005 

IF  CKDAY  >  MOLENGTH(CKMONTH) 

THEN  RT. 5000=3  :  GOTO  5009 

0E70 

10F2 

0E70 

10F2 

5009 

RETURN 

0E73 

10F2 

0E73 

10F2 

.... 

0E73 

10F2 

0E73 

10F2 

5010 

REM  SINCLUDE:  ■RACS5010.SUB' 

INCLUDE  THE  NUMERIC  STRING  EDITOR 

0674 

10F2 

REN 

***** 

0E74 

10F2 

REM 

***« 

AMBULATORY  CARE  DATA 

BASE  1  MAY  85 

**** 

0E74 

10F2 

REM 

*«** 

SKIP  COLE 

**** 

0E74 

10F2 

REM 

**«« 

SUBROUTINE  NAME 

RXXS5010.SUB 

**** 

0E74 

10F2 

REM 

**«« 

SCANNER  PROGRAM  # 

ALL 

**** 

0E74 

10f2 

REM 

FUNCTION 

THIS  SUBROUTINE  MODULE 

•  *** 

0E74 

10F2 

REM 

***« 

PERFORMS  A  NUMERIC  STRING 

**** 

0E74 

10F2 

REH 

EDIT. 

**** 

0E74 

10f2 

REM 

***• 

**** 

I 
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0E74 

10F2 

REH 

INPUT 

:  STRING  TO  BE  EDITED  IS  IN 

«**• 

0E74 

10F2 

REH 

THE  VARIABLE  NAMED 

**** 

0E74 

10F2 

REH 

•OC.SOIOS' 

***« 

0E74 

10F2 

REH 

**** 

0674 

10F2 

REH 

OUTPUT 

:  'RT.5010'  IS  THE  RETURN  CODE 

»«*« 

0E74 

10F2 

REH 

**•* 

VARIABLE.  IF  THIS  VARIABLE 

***« 

0E74 

10F2 

REH 

CONTAINS  ANY  NUMBER  OTHER 

**** 

0E74 

10F2 

REH 

•««« 

THAN  0,  AN  ERROR  IMS  FOUND 

**** 

0E74 

10F2 

REH 

**«• 

IN  THE  STRING. 

**«* 

0E74 

10F2 

REH 

•*'** 

**** 

0E74 

10F2 

REH 

RESERVED  LINE 

•*** 

0E74 

10F2 

REH 

•«** 

NUMBERS 

:  5011-5019 

•  ***  ***AAAA**A****l,iA*X*Ai  AtXXlA 

***« 

0E74 

10F2 

RT 

.5010  3  0 

0E7B 

10F2 

0E7B 

10F2 

FOR  15010  >  1  TO  LEN(CK.SOIOS) 

0E88 

10F4 

JS010>  ASC(HIDS(CK.S010S 

.15010,1)) 

''E9F 

10F8 

IF 

JS010  <  48  OR  J5010  > 

57  THEM  RT.5010  »  RT.5010  ♦  1 

0EC7 

10F8 

NEXT  15010 

0E08 

10F8 

0E08 

10F8 

RETURN 

OCOB 

10F8 

5500 

REM  INCLUDE:  •RACS5500.SUB' 

INCLUDE  THE  OUTPATIENT  UCA  CHECK  SUB 

OEOC 

10F8 

OEDC 

10F8 

5700 

REM  $ INCLUDE:  •RACS5700.SUB' 

INCLUDE  THE  HAP  ONES  TO  POSITION 

NO 

OEDO 

10F8 

REH 

OEDO 

10F8 

REH 

*««* 

AMBULATORY  CARE  DATA  BASE  29  UUL  85 

**** 

OEDO 

10F8 

REM 

0  R  BOLLING 

**** 

OEDO 

10F8 

REM 

SUBROUTINE  NAME 

:  RXXS5700.SUB 

**** 

OEDD 

10F8 

REM 

***« 

SCANNER  PROGRAM  # 

:  ALL 

**** 

.EDD 

10F8 

REM 

*««* 

FUNCTION 

:  THIS  SUBROUTINE  MODULE 

**** 

OEDD 

10F8 

REM 

«««« 

CONVERTS  A  BINARY  ARRAY  INTO 

**** 

OEDD 

10F8 

REH 

TUO  CHAR  COOES. 

**** 

OEDD 

10F8 

REH 

**** 

OEDD 

10F8 

REH 

INPUT 

:  INP.STOS  AS  STRING 

*•** 

OEDD 

10F8 

REM 

**** 

OEDO 

10F8 

REM 

•««« 

**** 

OEDD 

10F8 

REM 

OUTPUT 

:  BUF.STOS  AS  STRING. 

**** 

OEDD 

10F8 

REH 

***« 

**** 

OEDD 

lOFS 

REH 

«•** 

**** 

OEDD 

10F8 

REH 

***• 

RESERVED  LINE 

**** 

OEDO 

10F8 

REM 

**«* 

NUMBERS 

:  5710-5730 

«*** 

ono 

10F8 

REH 

****** 

0600 

10f8 

OEDD 

lOFS 

BUF.STO$="'' 

0EE6 

10F8 

N.STO= 

1 

OEEO 

10FA 

5710 

X.STO= 

INSTR(N.STO, INP.STOS,' 

1") 

OEFr 

lOFC 

IF  X.ST0=0  THEN  GOTO  5720 

THATS  ALL 

OFOE 

10FC 

N.STO 

=  X.STO  ♦  1 

NEXT  STARTING  POINT 

0F16 

lOFC 

X.STO 

=  X.STO  ♦  100 

PAD  WITH  LEADING  2ERO 

3r20 

10FC 

BUF.STOS  =  BUF.STOS  ♦  R10MT${STR$(X.STO),2) 

0F36 

10FC 

IF  N.STO  <=  LENdNP.STOS)  THEN  GOTO  5710 

0649 

10FC 

0F49 

10FC 

5720 

RETURN 
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0F4C 

10FC 

HCM 

0F4C 

10FC 

6000 

REN  SIMCLUDE:  ■RACS60aa.SU8>  INCLUDE  THE  INSTRING  DECODE  SUB 

0F40 

0F4D 

lOFC 

10FC 

REH 

REM 

AMBULATORY  CARE  DATA  BASE  13  APR  8S 

*«*• 

0F4O 

10FC 

REM 

*«*« 

SKIP  COLE 

•••* 

OFAO 

10FC 

REM 

**•* 

SUBROUTINE  NAME  : 

RXXS6000.SUB 

OFAO 

10FC 

REM 

SCANNER  PROGRAM  II 

ALL 

***# 

0F4O 

10FC 

REM 

FUNCTION  : 

THIS  SUBROUTINE  MODULE 

0F4O 

10FC 

REM 

PERFORMS  INSTRING  SEARCH 

0F40 

10FC 

REM 

0F4O 

10FC 

REM 

*«** 

INPUT 

STRING  TO  BE  SEARCHED  MUST 

0F4O 

10FC 

REM 

BE  IN  THE  VARIABLE  NAMED  : 

0F4O 

10FC 

REM 

•XS* 

**•* 

0F4O 

10FC 

REM 

0F4O 

10FC 

REM 

OUTPUT  : 

•TOT>  «  TOTAL  NUMBER  OF 

•*«* 

0F4O 

10FC 

REM 

HITS  IN  THE  DESTRING 

OfiO 

10FC 

REM 

■HOLOSO'  IS  THE  ARRAY 

0F40 

10FC 

REM 

CONTAINING  THE  NUMERIC 

0F4O 

10FC 

REM 

VALUE  OF  THE  HIT  POSITIONS 

0F4O 

10FC 

REM 

OF40 

0F4O 

10FC 

10FC 

REM 

REM 

RESERVED  LINE 

0F40 

10FC 

REM 

NUMBERS 

6001-6009 

OF40 

10FC 

REM 

0F4O 

10FC 

6001 

PTR  «  INSTR(X$,"1") 

OFSB 

10FC 

TOT  =  0 

0F62 

10FC 

WHILE 

PTR  >  0 

0F6O 

10FC 

T0T=T0T+1 

0F75 

10FC 

HOLO$<TOT)  =  RIGMTS(STR$(PTR),2) 

0F97 

10FC 

PTR*PTR+1 

0F9F 

10FC 

PTR  =  INSTR<PTR,X$,"1 

0FB1 

10FC 

WEND 

OFBS 

10FC 

RETURN 

OFEB 

10FC 

0FB8 

10FC 

0FB8 

10FC 

OFB8 

10FC 

7000 

REN  SINCLUDE:  •RACS7000.SU8' 

INCLUDE  THE  SCREEN  HEADER  SUB 

0FB9 

10FC 

REM 

0FB9 

10FC 

REM 

•  *«« 

AMBULATORY  CARE  DATA 

BASE  13  APR  85 

0FB9 

10FC 

REM 

***• 

SKIP  COLE 

0FB9 

10FC 

REM 

«•*« 

SUBROUTINE  NAME 

RACS7000.SU8 

OFB9 

10FC 

REM 

*«*« 

SCANNER  PROGRAM  0 

ALL 

***« 

0FB9 

10FC 

REM 

**** 

FUNCTION 

THIS  SUBROUTINE  MODULE 

**** 

0FB9 

lOfC 

REN 

PRINTS  THE  STANDARD  SCREEN 

0FB9 

10FC 

REM 

**** 

HEADING. 

•••• 

0FB9 

10FC 

REN 

**•* 

INPUT 

COMMON  VARIABLE  USERS(2) 

0FB9 

10FC 

REM 

SYSTEM  DATE 

0FB9 

10FC 

REM 

**** 

0FB9 

10FC 

REM 

**** 

OUTPUT 

SCREEN  HEADING 

•*** 

0FB9 

10FC 

REM 

«**« 

0FB9 

10FC 

REN 

RESERVED  LINE 

0FB9 

10FC 

REM 

***• 

NUMBERS 

7001-7010 

RACP950 
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0FB9  10FC 

0FB9  10FC  7001  LOCATE  1.1 

0FC3  10FC  PRINT  «U.S.  ARMY  AMBUUTORr  CARE  INFORMATION  SYSTEM" 

OFCB  10FC  LOCATE  1,65 

0FD8  10FC  PRINT  DATES; 

OFEO  10FC  LOCATE  2,1 

OFED  10FC  PRINT  "USER  :  ".-USERSd) 

OFFA  10FC  RETURN 


OFFO 

10FC 

7100 

REM  SINCLUOE:  •RACS7100.SUS 

INCLUDE  THE  PRINTER  HEADER  SUB 

lOfC 

REM 

OFFE 

10FC 

REM 

AMBULATORY  CARE  OATA  BASE  13  APR  85 

OFFE 

10FC 

REN 

SKIP  COLE 

OFFE 

10FC 

REN 

***« 

SUBROUTINE  NAME 

:  RXXS7100.SUS 

OFFE 

10FC 

REM 

SCANNER  PROGRAM  » 

:  ALL 

***• 

OFFE 

10FC 

REM 

FUNCTION 

:  THIS  SUBROUTINE  MODULE 

**•* 

OFFE 

10FC 

REM 

•««« 

PRINTS  THE  STANDARD  HEADING 

**•« 

OFFE 

10FC 

REM 

**** 

ON  THE  PRINTER. 

***• 

OFFE 

10FC 

REM 

INPUT 

:  DATE, PAGE. PGNIDS.PGMTITLS 

OFFE 

10FC 

REM 

•«*« 

OFFE 

10FC 

REM 

**** 

OUTPUT 

:  PRINTER  HEADING,  LN. COUNT 

**«* 

OFFE 

10FC 

REM 

OFFE 

10FC 

REM 

RESERVED  LINE 

TFE 

10FC 

REM 

NUMBERS 

;  7101-7110 

*•»* 

OFFE 

10FC 

REM 

OFFE 

10FC 

OFFE 

10FC 

7101 

IF  PAGE 

>  0  THEN  LPRINT  CHR${12); 

<014  10FC  LPRINT  "ARMY  AMBULATORY  CARE  INFORMATION  SYSTEM *;PGHTITLS; 

1021  10FC  LPRINT  TAB<70), -OATES 

1034  10FC  PAGE=PAGE+1 

103C  10FC  LPRINT  "PROGRAM  ";PGMI0$:TAB(70);«PAGE"; 

1059  10FC  LPRINT  USING  "##IIW";PAGE 

1065  lOFC  LPRINT 

’160  10FC  LM.COUNT=3 

1074  10FC  RETURN 

1077  10FC 


1077 

10FC 

8000 

REM  SINCLUOE:  'RACS8000.SUB' 

INCLUDE  THE  DECODE  SUB  GROUP 

1078 

10FC 

REM 

1078 

10FC 

REM 

AMBULATORY  CARE  OATA  BASE  13  APR  85 

1078 

10FC 

REM 

SKIP  COLE 

1078 

10FC 

REM 

«•** 

SUBROUTINE  NAME 

:  RXXS8000.SUB 

•** 

1078 

10FC 

REM 

««** 

SCANNER 

PROGRAM  « 

:  ALL 

*** 

1078 

10FC 

REM 

«*«« 

FUNCTION 

:  THIS  SUBROUTINE  MODULE 

**• 

1078 

10FC 

REM 

«*** 

IS  A  GROUPING  THAT  PERFORMS 

1078 

10FC 

REM 

*«•* 

VARIOUS  DECODING  FUNCTIONS 

*•« 

10  3 

10FC 

REM 

**** 

ON  THE  SCANNER  DATA 

•  ** 

1078 

10FC 

REM 

**«* 

*** 

1078 

10FC 

REM 

**** 

8001  - 

DECODE  THE 

HEADER  POSITIONS  (POINTER  0-20) 

*** 

1078 

10FC 

REM 

8050  - 

CHECK  FOR 

END  OF  .108 

*** 

1073 

10FC 

REM 

**•« 

8100  - 

PRINT  THE 

HEADER  DATA  ON  THE  SCREEN 

**• 

1078 

10FC 

REM 

**** 

8200  - 

DECODE  THE 

RESPONSE  POSITIONS  (POINTER  21- . 

.) 

1078 

10FC 

REM 

***♦ 

ORETURNEO 

IN  TEXTS  STRING  VARIABLE) 

*•* 

1078 

10FC 

REM 

*** 

1078 

10FC 

REM 

**#• 

INPUT 

:  SHEET  RECORD,  RECORD  LENGTH 

*** 

RACP950 

SOCIAL  UOAK  SHORT  FORM 
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Offset 

Data 

Source 

Line 

IBM  Personal  Computer  BASIC  Coepiler  VI. 00 

1078 

10FC 

REM 

***« 

*** 

1078 

10FC 

REM 

****  OUTPUT  :  'TEXTS'  TRINC  VARIABLE 

*** 

1078 

10FC 

REM 

*** 

1078 

10FC 

REM 

•«*  RESERVED  LINE 

•*« 

1078 

10FC 

REM 

**•*  NUMBERS  :  8001-8500 

•*« 

1078 

10FC 

REM 

«««**•*«* 

1078 

10FC 

1078 

10FC 

•DECOOE  THE  HEADER  ONLY 

1078 

10FC 

8001 

POINTER  >  0 

107F 

10FC 

RECOROPTR  >  VARPTRCSHEETRECCO)) 

1086 

10FE 

FOR  J8000  >  1  TO  21 

1080 

10FE 

8002 

TEXTS*  TEXTS*CHRS(PEEK(RECOROPTR  «  POINTER}) 

10AB 

10FE 

POINTER*POINTER+1 

1083 

10FE 

NEXT  J8000 

10C2 

1100 

PROGRAMS*  LEFTS(TEXTS,3) 

1001 

1104 

BATCHS*  MI0S<TEXTS.4,3) 

10E3 

1108 

SERIALS*  MI0S(TEXTS,7,4) 

10FS 

HOC 

RUNIDS*  MI0S(TEXTS.11,1) 

1107 

1110 

FORKS*  MIDS(TEXTS,12.2} 

1119 

1114 

POCKETS*  MI0S(TEXTS,14,1) 

1128 

1118 

SCANERR1S*MI0S(TEXTS, 16,2) 

1130 

me 

SCANERR2S*MI0S(TEXTS. 18,2) 

114F 

1120 

SCANERR3S*MIDS<TEXTS,20,2) 

1161 

1124 

GOTO  8500 

1165 

1U4 

1165 

1124 

8050 

REM  CHECK  FOR  END  OF  J06/EN0  OF  BATCH 

1166 

1124 

IF  PROGRAMS  ■  PGM I OS  THEN  GOTO  8500 

1178 

1124 

LPRINT  STRINGStOO,"*") 

1186 

1124 

LPRINT 

118E 

1124 

LPRINT  "RECORDS  PROCESSED  ...  ■;SERIALS 

1198 

1124 

LPRINT  "STARTED  AT  .  «;BTIMES 

11A8 

1124 

LPRINT  "ENDED  AT  .  «;TIHES 

1185 

1124 

LPRINT  CHRS(12] 

11C0 

1124 

GOTO  30000 

11C4 

1124 

11C4 

1124 

8070 

REM  CHECK  FOR  SCANNER  ERRORS 

lies 

1124 

IF  POCKETS  *  "  "  GOTO  8500 

1107 

1124 

LPRINT  LITHOS; 

11DF 

1124 

LPRINT  "  ...  SCANNER  ERRORS  :  •; 

11E7 

1124 

LPRINT  SCANERR1S;"  /  "; 

11F4 

1124 

LPRINT  SCANERR2S;"  /  "; 

1201 

1124 

LPRINT  SCANERR3S 

1209 

1124 

LN*LN+1 

1211 

1126 

GOTO  999 

1215 

1126 

y 

1215 

1126 

8100 

REM  PRINT  THE  HEADER  VARIABLES  ON  THE  TUBE.... 

1216 

1126 

LOCATE  5,1:PRINT  "PROGRAM  ".-PROGRAMS; 

1230 

1126 

1230 

1126 

PRINT  "  BATCH  ";BATCHS; 

1230 

1126 

PRINT  "  RUN  ";RUNI0S; 

124  A 

1126 

PRINT  "  FORM  "; FORMS; 

1257 

1126 

PRINT  "  POCKET  "; POCKETS 

1264 

1126 

GOTO  8500 

■I 
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1268  1126  8200  REN  DECODE  THE  RESPONSE  POSITIONS 

1269  1126  POINTER  «  21 

1270  1126  RECOROPTR  <  VARPTR(SHEETREC(0)) 

1277  1126  FOR  J8000  -  22  TO  RECOROLENGTH 

1284  1128  8202  TEXTS  ■  TEXTS+CHRS(PEEK(RECORDPTR  *  POINTER)) 

12A2  1128  POINTER>POINTER'»1 

12AA  1128  NEXT  J8000 

12BB  1128 

12BB  1128  8500  RETURN 

128E  1128 

12BE  1128  REM . END  OF  RXXS8000.SUB . 

.2BE  1128 

12BE  1128  9000  REN  SINCLUDE:  'RACS9000.SU8>  INCLUDE  THE  SCANNER  CONTROL  SUB 


12BF 

12BF 

1128 

1128 

REN 

REM 

*«*« 

*«#«**««*«««*«****«*******««******«««*«**«***ft*#««******1 

AMBULATORY  CARE  DATA  BASE  13  APR  85 

*«** 

12BF 

1128 

REM 

»*** 

SKIP  COLE 

•  **« 

12BF 

1128 

REM 

***« 

PROGRAM  NAME 

:  RACS9000.SUB 

**** 

12BF 

1128 

REM 

SCANNER  PROGRAM  « 

:  ALL 

**** 

12BF 

1128 

REM 

FUNCTION 

:  THIS  SUBROUTINE  MODULE 

*«*• 

12BF 

1128 

REM 

**** 

CONTROLS  THE  SCANNER  I/O 

*•** 

12BF 

1128 

REN 

***« 

12SF 

1128 

REM 

INPOT/OUTPUT 

:  REFER  TO  THE  ASYNCHRONOUS 

12SF 

1128 

REN 

COMMUNICATIONS  MANUAL  AND  THE 

•2BF 

1128 

REM 

PRE-RELEASEO  SOFTWARE  GUIDE 

**«• 

f2aF 

1128 

REM 

**#* 

12BF 

1128 

REM 

12BF 

1128 

REM 

RESERVED  LINE 

**«• 

'2BF 

1128 

REM 

NUMBERS 

:  9001-9100 

12BF  1128  REM  *•**«♦«*«♦«•««*«•«*♦«*«••**•««*«*«•«*««•**«««***««****«**•*«*«***** 

12BF  1128 

128F  1128 

12BF  1128  REM  *•••*••••*•*•***•••*••♦**•**•••***•*•••*•.*•*•*•*.**.•..**•.**••••. 

12BF  1128  REM  •••*  SUBROUTINE  9001  -  PROTOCOL  SETUP  FOR  SCANNER  ••••* 

128F  1128  REM  ••••  ARGUMENTS:  PRESET  ...  SEE  BELOW 

12BF  1128  REN  •***••••*•*••**••**••*••*••*•••••••*••*••***•***•*•.***••*«*.*.*.•• 

1  BF  1128  9001  REM 

12C0  1128  PROTOCOL(O)  =  9600  ■BAUD  RATE 

12C7  1128  PROTOCOL(I)  =  78  'PARITY  (SEE  PACE  4-8  OF  MANUAL) 

12CE  1128  PROTOCOL<2)  =  8  'DATA  BITS 

1205  1128  PROTOCOL{3)  «  1  'STOP  BITS 

120C  1128  PROTOCOL(4)  =  2  'RS-232  PORT 

12E3  1128  PROTOCOL(5)  =  0  'WRITE  TIME-OUT 

12EA  1128  PR0T0C0L{6)  =  0  'READ  TIME-OUT 

I2F1  1128 

12F1  1128  ERRSTATS  «  SPACE$(60) 

12FO  1128  ARGPTR  »  VARPTR{PROTOCOL{0)) 

1304  112A  CALL  SETUP  (ARGPTR, ERRSTATS) 

1315  112A  ERRMSG$="" 

13)E  112A  IF  ASC(ERRSTATS)  <>  64  THEN  ERRMSGS="SETOP  ERROR  "♦ERRSTATS 

133A  112A  GOTO  9100 

133E  112A 

133E  112A  REM 

133E  112A  REM  *»»»  SUBROUTINE  9010  -  CONTROL  OPTIONS  FOR  SCANNER  **••• 

133E  112A  REM  ARGUMENTS:  CNTRLOPT  •*•** 


RACP9S0 

SOCIAL  UQRK  SHORT  FORM 


Offset 

133E 

133E 

133E 

133E 

133E 

133E 

133E 

133E 

133E 

133E 

133F 

134B 

135C 

1365 

1361 

1385 

1385 

1385 

1385 

1385 

1385 

1385 

1385 

1385 

1385 

1385 

1385 

1385 

1386 
1392 
1399 
13B2 
13BB 
130C 
13E0 
13E0 
13E0 
13E0 
13E0 
13E0 
13E0 
13E0 
13E0 
13E0 
13E0 
13E0 
13E0 
13E0 
13E0 
13E1 
13ED 
13F4 
1409 
1425 


Data 


112A 

112A 

112A 

112A 

112A 

112A 

112A 

112A 

112A 

112A 

112A 

112A 

112A 

112A 

112A 

112A 

112A 

112A 

112A 

112A 

112A 

112A 

112A 

112A 

112A 

112A 

112A 

112A 

112A 

112A 

112A 

112A 

112A 

112A 

112A 

112A 

112A 

112A 

112A 

112A 

112A 

112A 

112A 

112A 

112A 

112A 

112A 

112A 

112A 

112A 

112A 

112A 

1130 

1130 


Source 

REM 

REN 

REM 

REN 

REM 

REN 

REN 

REM 

REN 

9010 


REN 

REM 

REN 

REM 

REN 

REN 

REM 

REM 

REM 

REN 

REM 

9020 


REM 

REM 

REM 

REN 

REN 

REM 

REM 

REM 

REN 

REM 

REM 

REM 

REN 

9030 
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Lina 

CNTRLOPT  «  1  «  START  SCANNER  (SI) 

*•••  CNTRLOPT  »  2  ■  STOP  SCANNER  (SO) 

CNTRLOPT  »  3  ■  TERMINATE  COMMUNICATIONS  TO  SCANNER  (0C3) 

****  CNTRLOPT  >  4  ■  CLEAR  TRANSPORT  PATH  (DC2) 

*•••  CNTRLOPT  «  5  ■  SELECT  PRIMARY  STACKER  “31“ 

CNTRLOPT  «  6  »  SELECT  SECONDARY  STACKER  "32“ 

CNTRLOPT  «  7  »  POSITIVE  RESPONSE/SELECT  SCANNER  (DC1) 

•••*  CNTRLOPT  =  8  »  REQUEST  STATUS  (ESC) 

******************************************************************* 

REN 

ERRSTATS  >  SPACES(60) 

CALL  CNTROL  (CNTRLOPT, ERRSTATS) 

ERRMSGS^"" 

IF  ASC(ERRSTATS)  <>  64  THEN  ERRMSGS*»CONTROL  ERROR  ■♦ERRSTATS 
GOTO  9100 

******************************************************************* 

SUBROUTINE  9020  •  SCAN  SHEET  CALL 

•••• 

ARGUMENTS:  REAOTYPE 

•***  REAOTYPE  -  2  >  REOUEST  NEU  DOCUMENT  FROM  SCANNER 
REAOTYPE  «  3  «  RETRANSMIT  CURRENT  DOCUMENT 

ARGUMENTS:  RECOROLENGTH 

••••  NUMERIC  VARIABLE  SET  TO  THE  HUMBER  OF  CHARACTERS  TO  BE 
*•••  TRANSMITTED 

REM 

ERRSTATS  >  SPACES(60) 

RECOROPTR  X  VARPTR(SHEETREC(0)) 

CALL  SCAN  (REAOTYPE, RECORDLENGTH.RECOROPTR.ERRSTATS) 

ERRMSGS>"" 

IF  MIDS(ERRSTATS,14,3)  «  "415"  THEM  ERRMSGS»"ESC" 

GOTO  9100 


IBM  Personal  Coaiputer  BASIC  Coapilar  VI. 00 

***** 

***** 

***** 

***** 

***** 

***** 

***** 


******************************************************************* 

*•*•  SUBROUTINE  9030  -  TRANSPORT  PRINT  CALL  *•••• 

****  ***** 

ARGUMENTS:  PRINTPOS  •***• 

NUMERIC  VARIABLE  INDICATING  THE  STARTING  PRINT  POSITION  ***** 
****  VALUES  »  0  THRU  90  ***** 

**•*  ***** 

*•*•  ARGUMENTS:  PSTRIHGS  ***** 

*•**  TEXT  TO  BE  PRINTEO  ON  THE  FORM  ***** 

****  ***** 

****  NOTE:  THIS  ROUTINE  HAS  NO  EFFECT  UNLESS  THE  SCAN  ***** 

.****  HEAOER  SHEET  IS  MARKEO  'PRINTER  ON'  ***** 


ERRSTATS  >  SPACES(60) 

RECOROPTR  >  VARPTR(SHEETREC(0)) 

CALL  TPR I NT(PR I NTPOS , PSTR I NGS, ERRSTATS) 

IF  ASC(ERRSTATS)  <>  64  THEN  ERRMSGS=»PRIMT  ERROR  "♦ERRSTATS 
GOTO  9100 


RACP9S0 

SOCIAL  WORK  SHORT  FORM 


Offset 

Data 

Source  Line 

1429 

1130 

1429 

1130 

9100 

RETURN 

U2C 

1130 

K2C 

1130 

142C 

1130 

REM 

END  OF  SUBROUTINES  aassnxasasausssnsasusassssasssasssssssi 

142C 

1130 

142C 

1130 

25000 

REM  USER  TERMINATEO  INPUT...  FILE  IS  NOT  TO  BE  USED>l!n 

1420 

1130 

LPRINT  "USER  TERMINATEO  INPUT  ..  DATA  WILL  NOT  BE  USEDI" 

1435 

1130 

LPRINT  "ERASING  FILE  ";0ATFILS 

1442 

1130 

BEEP 

.446 

1130 

CLS  :  PRINT  "USER  TERMINDATEO  INPUT  ..  DATA  WILL  NOT  BE  USED! 

1452 

1130 

CLOSE 

1456 

1130 

OPEN  OATFILS  FOR  OUTPUT  AS  «1 

1468 

1130 

PRINT  <1.STRING$<RECOROLENGTH."X")  ‘VOID  THE  FIRST  RECORD 

147A 

1130 

CLOSE 

■:47E 

1130 

147E 

1130 

30000 

REM 

147F 

1130 

CLOSE 

1483 

1130 

CHAIN  “RACP10" 

1484 

1130 

END 

148E 

1130 

1491 

1130 

2.i151 

Bytes  Available 
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16V32  Bytes  Free 


0  Warning  Error<s) 
0  Severe  Error(s) 
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RACP05.LST  Initial  Sign-On 

RACPIO.LST  Initial  Selection  Menu 

RACPIA.LST  OMR  (Scanner)  Select 
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001A 

0002 

REM  SLINESIZE 

:132 

001A 

0002 

REM  SPAGESIZE: 

66 

001A 

0002 

REN  STITLE: 

■RACPOS* 

001A 

0002 

REM  SSUBTITLE: 

■Initial  Sign-on  screen 

001A 

0002 

REM  SPACE 

RACPOS 

Initial  Sign-on  screen 
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Offset  Data  Source  Line  IBM  Personal  CoafXiter  BASIC  Compiler  VI. 00 

001A  0002  REN  . . . 

001A  0002  REH  I  NAME:  RACPOS  AMBULATORY  CARE  INFORMATION  SYSTEM  LOGON  | 

001A  0002  REM  |  WRITTEN  BY:  FLOYD  COLE  | 

OOIA  0002  REM  |  MODIFIED  FOR  NEW  FORM  DESIGN  2  JAN  87  BY  DAVID  BOLLING  | 

001A  0002  REM  . . . 

OOIA  0002  REM  This  is  the  first  program  in  the  Aotxjtatory  care  series.  Its 

OOlA  0002  REM  purpose  is  to  log  the  user  on  to  the  system.  From  there, 

OOIA  0002  REM  control  is  passed  to  RACP10  and  a  MAIN  menu  which  allows  the  user 

OOIA  0002  REM  to  invoke  various  system  options. 

OOIA  0002  REM 

OOIA  0002  REM  The  program  is  called  from  the  autoexec.bat  file  on  boot. 

OOIA  0002  REM  Control  is  returned  to  this  progrom  on  logoff  from  any  of  the 

OOIA  0002  REM  other  basic  system  modules.  The  system  is  a  closed,  tightly 

OOIA  0002  REM  controlled  loop. 

OOIA  0002  REM  . 

OOIA  0002  REM  tlNCLUOE:  'RACDIM.MOO'  REM  Include  the  DIMENSION  DEFINITIONS 

OOIA  0002  •  ••••*****************•***•**«******.***.****.*******.*.*..*.*.*****... 

OOIA  0002  '*  NAME:  RACDIM.MOO  DIMENSION  DEFINITIONS  * 

OOIA  0002  '•  Date:  28  Feb  84  Written  by;  Floyd  Cole  • 

OOIA  0002  ' •****•***•••••*•••••••**•••**••••••*••••*****•••••**•***••****•**•••** 

OOIA  0002  '  Dimensioned  variables  are  defined  in  this  file. 

OOIA  0002  '  It  is  an  included  file  so  it  cannot  be  run  in  a  stand-alone, 

OOIA  0002  •  mode. 

OOIA  0002  • 

OOIA  0002  '  This  program  segment  may  be  modified,  but  all  files  containing 

OOIA  0002  '  an  include  for  this  segment  must  be  re-compiled  in  order  to 

OOIA  0002  '  affect  the  changes  made  here. 

OOIA  0002  '  ***♦••***.**  START  OF  DIMENSION  DEFINITION  ••••••••••*•*•******* 

OOIA  0002 

OOIA  0002  DEFINT  A-2 

OOIA  0002  DIM  USER$<2),MOL£NGTH(12),OATEERR$<3) 

OOIA  0002 

OOIA  0002  ■  ••••••*••••*  ENo  OF  DIMENSION  DEFINITIONS  *•***••••••••***•*•*• 

OOIA  0002 

OOIA  0002  REM  SINCLUOE:  'RACCMM.MOO'  REN  Include  the  COMMON  AREA  DEFINITION 

OOIA  0002  ' •*••••**•*******•****•*••**•*••*•**.*♦*•••**•*•***•********♦**••«**♦** 

OOIA  0002  NAME:  RACCMN.MOO  COMMON  AREA  DEFINITION  • 

OOIA  0002  '*  Date:  28  Feb  84  Written  by:  Floyd  Cole  * 

OOIA  0002  •********♦***•****••*••••••*•*•*****.•**•**••*••.•*.*•*•****•...«*.**** 

OOIA  0002  '  COMMON  AREA  DEFINITIONS  WILL  BE  HELD  IN  THIS  FILE.  IT  IS  AN 

OOIA  0002  '  INCLUDED  FILE  SO  IT  CANNOT  BE  RUN  IN  A  STAND-ALONE,  MODE. 

OOIA  0002  • 

OOIA  0002  '  This  program  segment  may  be  modified,  but  all  files  containing 

OOIA  0002  '  an  include  for  this  segment  must  be  re-compiled  in  order  to 

OOIA  0002  '  affect  the  changes  made  here. 

OOIA  0002  • 

OOIA  0002  •  *******«****«START  OF  COMMON  DEFINITIONS— — — — — — — — 

OOIA  0002 

OOIA  0002  COMMON  FORE, BACK, BOARD, HIDE, EFORE,EBACK, BELLS  'BASIC  SCREEN  COLORS 

OOIA  0002  COMMON  HEADERS  '21  CHARACTER  SCANNER  HEADER  INFO 

OOIA  0002  COMMON  TEXTS  "  AINING  CHARACTERS  FROM  SCANNER 

OOIA  0002  COMMON  PGMIDS  'PROGRAM  OR  FORM  ID 

OOIA  0002  COMMON  MOLENGTHO  'DAYS  IN  THE  MONTH  ; 

OOIA  0002  COMMON  USERSO 


RACPOS 
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001A  0002  '  *••*******♦**£«)  OF  COMMON  0EFINITI0N*»****«***********»«**»** 

001A  0002 

001A  0002  REM  SINCLUOE:  'RACFUN.MCO'  REM  Include  the  FUNCTION  DEFINITIONS 

001A  0002  REM  ♦ . ♦ 

001A  0002  REM  |  NAME:  RXXFUN.MOO  FUNCTIONS  DEFINITIONS  | 

001A  0002  REN  j  Date:  28  Feb  84  Written  by:  Floyd  Cole  | 

001A  0002  REN  ♦ . ♦ 

001A  0002  REM  Defined  functions  will  held  in  this  file. 

001A  0002  REM  It  is  an  included  file  so  it  cannot  be  run  in  a  stand-alone, 

001A  0002  REM  mode. 

001A  0002  REM 

001A  0002  REM  This  program  segment  may  be  modified,  but  all  files  containing 

001A  0002  REM  an  include  for  this  segment  must  be  re-compiled  in  order  to 

001A  0002  REM  affect  the  changes  made  here. 

001A  0002  REN 

001A  0002 

001A  0002  REM  . START  OF  FUNCTION  DEFINITION . 

001A  0002  REM  NO  FUNCTIONS  CURRENTLY  DEFINED 

001 A  0002  ON  KEY  (1)  GOSUB  3001 

0040  0012  ON  KEY  (2)  GOSUB  3002 

004A  0012  ON  KEY  (3)  GOSUB  3003 

0054  0012  ON  KEY  (4)  GOSUB  3004 

005E  0012  ON  KEY  (5)  GOSUB  3005 

0068  0012  ON  KEY  (6)  GOSUB  3006 

0072  0012  ON  KEY  <7)  GOSUB  3007 

•  007C  0012  ON  Key  m  GOSUB  3008 

0386  0012  ON  KEY  (9)  GOSUB  3009 

0090  0012  ON  KEY  (10)  GOSUB  3010 

009A  0012  REM  . END  OF  FUNCTION  DEFINITION . 

009A  0012  REM  SINCLUDE:  'RACOEF.MOO'  REM  Include  the  DEFAULT  DEFINITIONS 

009A  0012  • **••••**••****•**••»••**••**••*••***•***•**••••••••.*****•******••**** 

009A  0012  ■*  NAME:  RACP01.0EF  DEFAULT  DEFINITIONS  * 

009A  0012  '*  Date:  28  Feb  84  Written  by:  Floyd  Cole  * 

009A  0012  .***•»***•**.•*♦•****.***.***»**».********.***»**********..**..***.**** 

OOCA  0012  '  Variables  used  in  coinnon  that  have  a  default  value  on  start*up 

009A  0012  ’  will  be  held  in  this  file.  It  is  an  included  file  so  it  cannot 

009A  0012  '  be  run  in  a  stand*8lone  mode.  In  normal  operation,  this  file 

009A  0012  '  should  be  'included'  in  the  main  program  only  (RACP10.BAS). 

009A  0012 

009A  0012  '  This  program  segment  may  be  modified,  but  all  files  containing 

009A  0012  '  an  include  for  this  segment  must  be  recompiled  in  order  to 

009a  0012  '  affect  the  changes  made  here. 

009A  0012  ' 

009A  0012 


009a 

0012 

••START  OF  DEFAULT  OEFINITION^^*^^^^^* 

009A 

0012 

FORE  = 

15 

'FOREGROUND  COLOR  =  INTENSE  WHITE 

00A1 

0012 

BACK  = 

1 

'Background  Color  =  Light  Blue 

00A8 

0012 

BORD  = 

4 

'BORDER  =  RED 

OOAF 

0014 

HIDE  > 

4 

'ALTERNATE  COLOR  >  RED 

00B6 

0014 

EFORE= 

14 

'ERROR  FOREGROUND  DISPLAY 

OOBO 

0014 

EBACK* 

0 

'ERROR  BACKGROUND  DISPLAY 

OOC4 

0014 

BELLS  = 

CHR$(7> 

'Sound  the  bell 

0000 

0014 

OODO  0014 


HOLENGTH(I) 


31 


'JAN 


RACP05 

Initial  Sign-on  screen 


Offset  Data  Source  Line 
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0007  0014 
OOOE  0014 
00E5  0014 
OOEC  0014 
00F3  0014 
OOFA  0014 
0101  0014 
0108  0014 
010F  0014 
0116  0014 
0110  0014 
0124  0014 
0124  0014 
0120  0014 
0136  0014 
013F  0014 
0148  0014 
0148  0014 
014F  0016 
0158  001A 
0158  001A 
0158  001A 
0158  001A 
0158  001A 
015F  001A 
0175  001A 
0179  001A 
0182  001A 
0188  001A 
018F  001A 
0194  001A 
0194  001A 
01A6  001A 
01B1  001A 
01B5  001A 
01B5  001A 
01C7  001A 
01CB  001A 
01CB  001A 
01CC  001A 
01D9  001A 
01E1  001A 
01  EE  001 A 
01F6  001A 
0203  001A 
020B  001A 
0218  001A 
0220  001A 
0220  001A 
0221  001A 
022E  001A 
023C  001A 
0249  001A 
0257  001A 


NOLENGTH(2) 

a 

28 

'FEB  <--MOOIFIED  IN  SUBROUTINE  RACS5000. 

HOLENGTH(3) 

= 

31 

'MAR 

MOLENGTH(4) 

s 

30 

'APR 

MOLENGTH(5) 

= 

31 

'MAY 

MOLENGTH(6) 

= 

30 

'JUN 

MOLENGTH(7) 

= 

31 

'JUL 

HOLENGTH(8) 

a 

31 

■AUG 

MOLENGTH(9) 

= 

30 

■SEP 

MOLENGTH(IO) 

a 

31 

■OCT 

MOLENGTH(11> 

a 

30 

■NOV 

HOLENGTH(12) 

= 

31 

■DEC 

DATEERRS(O) 

s 

II  II 

DATEERRS(I) 

= 

"INVALID 

MONTH" 

0ATEERRS(2) 

= 

"INVALID 

DAY  " 

DATEERRS(3} 

a 

"DAY  TOO 

LARGE  FOR  MONTH  COOED" 

HAXLENGTH 

a 

80 

■MAXIMUM  LENGTH  OF  OUTPUT  RECORD 

PADS 

a 

" . " 

■PAD  CHARACTER  FOR  SHORT  RECORDS 

'END  OF  DEFAULT  DEFINITION' 


10  KEY  (3)  ON 

COLOR  FORE. BACK, BOND 
CLOSE 

USERSd  )="•*****'• 

USER$(2)=''»*****" 

100  CLS 

110  GOSUB  7000  'PRINT  THE  HEADING 

OPEN  "0",1, "RACB00.BAT" 

PRINT  #1,  "CLS" 

CLOSE 

OPEN  "0",1, "RACLOG.DAT" 

CLOSE 

200  REM  SETUP  THE  LOGON  SCREEN 
LOCATE  12,30 

PRINT  "PLEASE  LOG  ON:  " 

LOCATE  16,30 

PRINT  "USER  CODE  .  " 

LOCATE  18,30 

PRINT  "PASSWORD  .  " 

LOCATE  22,24 

PRINT  "KEY  'END*  IN  USER  CODE  TO  EXIT" 

300  REM  INPUT  THE  USER  CODE  AND  PASSWORD 

LOCATE  16,50  'CLEAR  THE  PREVIOUS  ENTRIES 

PRINT  SPC(30); 

LOCATE  18,50 
PRINT  SPC(30); 


RACPOS 

Initial  Sign-on  screen 


Oi'rset  Data 

Source  Line 

0257 

001A 

LOCATE  16,50  'POSITIOM  ABO  RETRIEVE 

0264 

001A 

LINE  INPUT.-USERSd) 

0270 

001A 

IF  USERS! 1>  <>  "END"  AND  USERS! 1)  <>  “end"  THEN  GOTO  307 

0297 

001A 

0297 

001A 

OPEN  •'0",1,"RACFPUD.FEX" 

02A9 

001 A 

PRINT  #1, »•***•*•<• 

02B4 

001A 

CLOSE 

02B8 

001A 

02B8 

001A 

COLOR  7,0,0 

02C7 

001A 

CLS 

02CB 

001A 

END 

02CF 

001 A 

02Cf 

001A 

307 

LOCATE  18,50 

020C 

001A 

COLOR  HIDE, HlOE, BORO  'HIDE  THE  INPUT 

02EE 

001A 

LIME  INPOT;USERS!2) 

02FA 

001A 

COLOR  FORE, BACK, BORO  'RESET  THE  COLOR  PATTERN 

0310 

001A 

0310 

0J1A 

310 

REN  CHECK  FOR  THE  OBVIOUS 

0311 

001A 

IF  USERS!  1)=''"  OR  USERS!2)=""  GOTO  300  ‘BLANKS 

0338 

001A 

CLS 

033C 

001A 

033C 

001A 

400 

REM  CONVERT  TO  CAPS 

0330 

001A 

FOR  J  =  1  TO  2  'CONVERT  USER. ID  AND  PASSWORD 

0344 

001 A 

AS=UStRSlJ) 

H 

0020 

FOR  1  =  1  TO  LEN!AS) 

^  tI366 

0022 

BSsMIDS!AS,I,1) 

0379 

0028 

IF  ASC!BS)  >  47  AND  ASCIB$)<  91  THEN  450 

03A0 

0028 

M10$IAS,I,1)=CHRS!ASC!NIDS!AS,I,1))  XOR  32) 

03BC 

0028 

450 

NEXT  I  'EMO  OF  CAPS 

03CO 

0028 

USER$!J)=AS  'REPLACE  THE  VARIABLE 

03E1 

0028 

NEXT  J 

03F3 

0028 

03F3 

0028 

IF  USERS!2)="LUGNUT"  THEN  470 

0401 

0028 

IF  USERS!2)="NUTMEG"  THEN  470 

040F 

0028 

IF  USERS!2)=''REDUAX"  THEN  470 

0410 

0028 

IF  USERS!2)=''UETHEN"  THEN  470 

042P 

0028 

IF  USERS!2)=''8IGJAR''  THEN  470 

0439 

0028 

IF  USERS!2)="BAYRUM"  THEN  470 

0447 

0028 

0447 

0028 

LOCATE  20,30 

04S4 

0028 

PRINT  "UNAUTHORIZED  PASSWORD" 

045C 

0028 

GOTO  110 

0460 

0028 

0460 

0028 

470 

REM  WRITE  ENCRYPTED  PASSWORD 

0461 

0028 

OPEN  "RACFPWD.FEX"  FOR  OUTPUT  AS  #2 

0473 

0028 

FOR  1=1  TO  6 

047A 

0028 

PWS=PW$+CHR$(ASC(MIDSlUSER$!2),7-I,1))t10+I) 

049F 

002C 

NEXT  I 

04AE 

002C 

PWS=PW$+CHRS!ASC!MID$IUSERS12),4,1))*17) 

04CB 

002C 

PRINT  #2,PWS 

0406 

1  002C 

CLOSE  2 

0400 

002C 

0400 

1  002C 

OPEN  "0",1, "RACLOG.DAT" 

04EF 

002C 

PI  )1>="RACP05" 
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RACP05 

Initial  Sign-on  screen 


Offset 

Data 

Source  Line 

04F8 

0030 

WRITE  #1,  USERSd) 

0513 

0030 

CLOSE 

0517 

0030 

CHAIN  •■RACPIO^^ 

051E 

0030 

051E 

0030 

051E 

0030 

3000 

REM  PF  KEY  TRAPS 

051 F 

0030 

051 F 

0030 

3001 

REM  PF  1  =  HELP 

0520 

0030 

KEY  (1)  OFF 

0527 

0030 

RETURN  10 

0520 

0030 

0520 

0030 

3002 

REM  PF  2  =  UNUSED 

052E 

0030 

KEY  (2)  OFF 

0535 

0030 

RETURN  10 

053B 

0030 

053B 

0030 

3003 

REM  PF  3  =  UNUSED 

053C 

0030 

CLOSE  :  CLS  :  END 

0548 

0030 

0548 

0030 

3004 

REM  PF  4  >  UNUSED 

0549 

0030 

KEY  (4)  OFF 

0550 

0030 

RETURN  10 

0556 

0030 

0556 

0030 

3005 

REM  PF  5  =  UNUSED 

0557 

0030 

KEY  (5)  OFF 

055E 

0030 

RETURN  10 

0564 

0030 

0564 

0030 

3006 

REM  PF  6  z  UNUSED 

0565 

0030 

KEY  (6)  OFF 

056C 

0030 

RETURN  10 

0572 

0030 

0572 

0030 

3007 

REM  PF  7  =  UNUSED 

0573 

0030 

KEY  (7)  OFF 

057A 

0030 

RETURN  10 

0580 

0030 

0580 

0030 

0580 

0030 

3008 

REM  PF  8  »  UNUSED 

0581 

0030 

KEY  (8)  OFF 

0588 

0030 

RETURN  10 

058E 

0030 

058E 

0030 

3009 

REM  PF  9  =  UNUSED 

058F 

0030 

KEY  (9)  OFF 

0596 

0030 

RETURN  10 

059C 

0030 

059C 

0030 

3010 

REM  PF10  c  UNUSED 

059D 

0030 

KEY  (10)  OFF 

05A4 

0030 

RETURN  10 

05  AA 

0030 

05  AA 

0030 

7000 

REM  PRINT  THE  HEAD 

05AB 

0030 

REM 

SINCLUDE:  'RACSTOOO.I 

05AB 

0030 

REM 

05AB 

0030 

REM 

AMBULATORY 

05AB 

0030 

REM 

**** 

05AB 

0030 

REM 

SUBROUTINE 

05AB 

0030 

REM 

•••*  SCANNER  PR( 
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■DISABLE  PF  KEY 


■DISABLE  PF  KEY 


■DISABLE  PF  KEY 


■DISABLE  PF  KEY 


■DISABLE  PF  KEY 


■DISABLE  PF  KEY 


■DISABLE  PF  KEY 


■DISABLE  PF  KEY 


■DISABLE  PF  KEY 


13  APR  85 
SKIP  COLE 


RACS7000.SU8 


RACP05 

Initial  Sign-on  screen 


V 


Jffset 

Data 

Source 

Line 

OSAB 

0030 

REM 

**** 

FUNCTION 

• 

THIS  SUBROUTINE  MODULE 

OSAB 

0030 

REM 

**«« 

PRINTS  THE  STANDARD  SCREEN 

OSAB 

0030 

REH 

HEADING. 

OSAB 

0030 

REM 

**** 

INPUT 

i 

COMMON  VARIABLE  USERS(2) 

OSAB 

0030 

REH 

**** 

SYSTEM  DATE 

OSAB 

0030 

REM 

**** 

OSAB 

0030 

REM 

**** 

OUTPUT 

: 

SCREEN  HEADING 

OSAB 

0030 

REM 

**** 

OSAB 

0030 

REM 

**** 

RESERVED  LINE 

OSAB 

0030 

REM 

«**• 

NUMBERS 

: 

7001-7010 

OSAB 

0030 

REH 

OSAB 

0030 

OSAB 

0030 

7001 

LOCATE 

1.1 

0SB5 

0030 

PRINT 

"U.S.  ARMY  AMBULATORY 

CARE 

INFORMATION  SYSTEM" 

OSBO 

0030 

LOCATE 

1.65 

05CA 

0030 

PRINT 

DATES; 

0502 

0030 

LOCATE 

2.1 

050F 

0030 

PRINT 

■•USER  :  ".-USERSd) 

05EC 

0030 

RETURN 

05EF 

0030 

05EF 

0030 

05F2 

0030 

22151 

Bytes  Available 

.  20364  Bytes  Free 

# 


0  Warning  Error(s) 
0  Severe  Error(s) 
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offset  Data 


Source  Line 
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001A 

0002 

REM  SLtNESIZE:132 

001A 

0002 

REM  SPAGESIZE:  66 

001A 

0002 

REM  STITLE:  ’RACPIO  • 

001A 

0002 

REM  tSUBTITLE: ' Initial  Selection  Screen 

001A 

0002 

REM  SPACE 

Initial  Selection  Screen 


Jffset 

001A 
001A 
001A 
001A 
001A 
001A 
OCIA 
001A 
001A 
001A 
001A 
001A 
001A 
001A 
001A 
001A 
001A 
001 A 
001A 
001A 
001A 
001A 
001A 
001A 
001A 
^QU 
001A 
001A 
001A 
001A 
001A 
001A 
001A 
001A 
001A 
001A 
001A 
0O1A 
001A 
001A 
001A 
001A 
001A 
001A 
001A 
001A 
001A 
001A 
001A 
001A 
001A 
'01A 
JOIA 
001A 
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0002 

0002 

0002 

0002 

0002 

0002 

0002 

0002 

0002 

0002 

0002 

0002 

0002 

0002 

0002 

0002 

0002 

0002 

0002 

0002 

0002 

0002 

0002 

0002 

0002 

0002 

0002 

0002 

0002 

0002 

0002 

0002 

0002 

0002 

0002 

0002 

0002 

0002 

0002 

0002 

0002 

0002 

0002 

0002 

0002 

0002 

0002 

0002 

0002 

0002 

0002 

0002 

0002 

0002 


REM  ♦ . . 

REM  I  Naaie:  RACP10  AsRxjlatory  Care  Inforawtion  System  MAIN  | 
REM  I  Date:  28  Feb  84  Written  by:  Floyd  Cole  | 
REM  I  Update:  23  Mar  87  Re-uritten  by:  D.  R.  Bolling  | 
REM  . . . 


REM  This  is  the  first  prograai  in  the  Asixilatory  care  series.  Its 
REM  purpose  is  to  log  the  user  on  to  the  system.  From  there, 

REM  a  main  menu  is  displayed  which  allows  the  user  to  perform 
REM  the  functions  of  the  system. 

REM 

REM  THE  PROGRAM  IS  CALLED  FROM  THE  AUTOEXEC.BAT  FILE  ON  BOOT. 

REM  CONTROL  IS  RETURNED  TO  THIS  PROGRAM  ON  LOGOFF,  EXIT  FROM 
REM  the  other  basic  modules  and  on  exit  from  PC/Focus.  It  is 
REM  a  closed  system. 

REM  . 

REM  SINCLUOE:  'RACDIM.MOO'  REM  Include  the  DIMENSION  DEFINITIONS 


*  NAME:  RACDIM.MOO  DIMENSION  DEFINITIONS 

*  Date:  28  Feb  84  Written  by:  Fioyd  Cole 

*************«*********************************«**************«*i 

Dimensioned  variables  are  defined  in  this  file. 

It  is  an  included  file  so  it  canrtot  be  run  in  a  stand-alone, 
mode. 


This  program  segment  may  be  modified,  but  all  files  containing 
an  include  for  this  segment  must  be  re-compiled  in  order  to 
affect  the  changes  made  here. 

••••**•*•*••  start  OF  DIMENSION  DEFINITION  ••••••***********•• 


OEFINT  A-2 

DIM  USER$(2),MOLENGTH(12),DATEERR$(3) 

I  •••••••*•*••  EMQ  Of  dimension  definitions  ***•••••»••******•*** 

REM  SINCLUDE:  'RACCMN.MOO'  REM  Include  the  COMMON  AREA  DEFINITION 


NAME:  RACCMN.MOO  COMMON  AREA  DEFINITION 

Date:  28  Feb  84  Written  by:  Floyd  Cole 


COMMON  AREA  DEFINITIONS  WILL  BE  HELD  IN  THIS  FILE.  IT  IS  AN 
INCLUDED  FILE  SO  IT  CANNOT  BE  RUN  IN  A  STAN0*AL0NE,  MODE. 

This  program  segment  may  be  modified,  but  all  files  containing 
an  include  for  this  segment  must  be  re*compiled  in  order  to 
affect  the  changes  made  here. 

***»*********START  OF  COMMON  DEFINITIONS**********************' 


COMMON  FORE, BACK, BOARD, HIDE, EFORE,EBACK, BELLS  'BASIC  SCREEN  COLORS 
COMMON  HEADERS  >21  CHARACTER  SCANNER  HEADER  INFO 

COMMON  TEXTS  "  AINING  CHARACTERS  FROM  SCANNER 

COMMON  PGM IDS  'PROGRAM  OR  FORM  ID 

COMMON  MOLENGTHO  'DAYS  IN  THE  MONTH 

COMMON  USERSO 


•’AGE  3 
08-03-87 
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001 A  0002  •  *************EN0  OF  COMMON  DEFINITION************************* 

001A  0002 

001A  0002  REN  SINCLUDE:  'RACFUN.MOO'  REM  Include  the  FUNCTION  DEFINITIONS 

001A  0002  REM  ♦ . ♦ 

001A  0002  REN  |  NAME:  RXXFUN.MOO  FUNCTIONS  DEFINITIONS  | 

001A  0002  REM  I  Date:  28  Feb  84  Written  by:  Floyd  Cole  j 

001A  0002  REM  + . ♦ 

001A  0002  REM  Defined  functions  will  held  in  this  file. 

001A  0002  REN  It  is  an  included  file  so  it  cannot  be  run  in  a  stand-alone, 

001A  0002  REN  mode. 

001A  0002  REN 

001A  0002  REM  This  program  segment  may  be  modified,  but  all  files  containing 

001A  0002  REM  an  include  for  this  segment  must  be  re-compiled  in  order  to 

001A  0002  REM  affect  the  changes  made  here. 

001A  0002  REM 

001A  0002 

001A  0002  REM  . START  OF  FUNCTION  DEFINITION . 

001A  0002  REM  NO  FUNCTIONS  CURRENTLY  DEFINED 

001 A  0002  ON  KEY  (1)  GOSUB  3001 

0040  0012  ON  KEY  (2)  GOSUB  3002 

004A  0012  ON  KEY  (3)  GOSUB  3003 

0054  0012  ON  KEY  (4)  GOSUB  3004 

005E  0012  ON  KEY  (5)  GOSUB  3005 

0068  0012  ON  KEY  <6)  GOSUB  3006 

0072  0012  ON  KEY  <7)  GOSUB  3007 

007C  0012  ON  KEY  (8)  GOSUB  3008 

0086  0012  ON  KEY  (9)  GOSUB  3009 

0090  0012  ON  KEY  (10)  GOSUB  3010 

009A  0012  REM  . END  OF  FUNCTION  DEFINITION . 

009A  0012  REM  SINCLUDE;  'RACOEF.MOO'  REM  Include  the  DEFAULT  DEFINITIONS 

009A  0012  ' •****•****•••*•••••••••**••*•**•••***•*••••*••***•*••••*•*****•*•**••* 

009A  0012  '*  NAME:  RACP01.DEF  DEFAULT  DEFINITIONS  * 

009a  0012  '*  Date:  28  Feb  84  Written  by;  Floyd  Cole  * 

009A  0012  •  *•••***•*•******•••*•**••***•*•**•********•*•*•*•••*•***•*••*••*****•• 

009A  0012  '  Variables  used  in  coninon  that  have  a  default  value  on  start*up 

009A  0012  '  will  be  held  in  this  file.  It  is  an  included  file  so  it  cannot 

009A  0012  '  be  run  in  a  stand*alone  mode.  In  normal  operation,  this  file 

009A  0012  '  should  be  'included'  in  the  main  program  only  (RACP10.BAS). 

009A  0012  ' 

009A  0012  '  This  program  segment  may  be  modified,  but  all  files  containing 

009A  0012  '  an  include  for  this  segment  must  be  re*compiled  in  order  to 

009a  0012  '  affect  the  changes  made  here. 

009A  0012  ' 

009A  0012 

009A  0012  •  •••••***.*«**staRT  OF  DEFAULT  DEFINITION************************ 

009A  0012  FORE  °  15  'FOREGROUND  COLOR  =  INTENSE  WHITE 

00A1  0012  BACK  =  1  'Background  Color  =  Light  Blue 

00A8  0012  BORD  s  4  'BORDER  =  RED 

OOAF  0014  HIDE  =  4  'ALTERNATE  COLOR  >  RED 

OOB6  0014  EFORE^  14  'ERROR  FOREGROUND  DISPLAY 

OOBO  0014  EBACK°  0  'ERROR  BACKGROUND  DISPLAY 

OOC4  0014  BELLS  »  CHRS(7)  'Sound  the  bell 

OODO  0014 

0000  0014 


RACP10 

Initial  Selection  Screen 
Offset  Data  Source  Line 


HOLENGTH(I) 


31 


'JAN 


RACP10 

Initial  Selection  Screen 


•  offset 

Oats 

Source  Line 

0007 

0014 

MOLENGTH(2) 

s 

28  'FEB  <--Na0IFIED  IN  SUBROUTINE  RACS5000 

OODE 

0014 

NOLENGTH(3) 

X 

31  'MAR 

OOE5 

0014 

HOLENGTH(4) 

X 

30  'APR 

OOEC 

0014 

MOLENGTH(S) 

X 

31  'MAY 

00F3 

0014 

N0LENGTH(6) 

X 

30  'JUN 

OOFA 

0014 

NOLENGTH(7) 

X 

31  'JUL 

0101 

0014 

NOLENGTH(8) 

X 

31  'AUG 

0108 

0014 

M0LENGTH(9) 

X 

30  'SEP 

010F 

0014 

MOLENGTH(IO) 

= 

31  'OCT 

0116 

0014 

HOLENGTHdl) 

X 

30  'NOV 

0110 

0014 

MOLENGTH(12) 

X 

31  'DEC 

0124 

0014 

0124 

0014 

OATEERRS(O) 

X 

N  M 

0120 

0014 

OATEERRS(I) 

= 

"INVALID  MONTH" 

0136 

0014 

0ATEERRS(2) 

X 

“INVALID  DAY  “ 

013F 

0014 

DATEERRS(3) 

X 

"DAY  TOO  LARGE  FOR  MONTH  COOED" 

0148 

0014 

0148 

0014 

HAXLENGTH 

= 

80  'MAXIMUM  LENGTH  OF  OUTPUT  RECORD 

014F 

0016 

PADS 

s  •* 

'PAD  CHARACTER  FOR  SHORT  RECORDS 

0158 

001A 

0158 

001A 

'END 

0158 

001A 

0158 

001A 

REM  . 

0158 

001A 

0158 

001A 

REH  CHECK  FOR  ENTRY 

•  0158 

001 A 

OPEN  "l",1, "RACLOO.DAT" 

016A 

001A 

IF  EOFO)  THEN  3010  'HAKE  THEN  LOG  ON  FIRST 

0178 

001A 

INPUT  #1,USER$<1) 

,DT$,TMS,PID$ 

0199 

0026 

IF  USERSd)  s 

MM 

THEN  3010  'MAKE  THEM  LOG  ON  FIRST 

01A7 

0026 

IF  USERSd)  = 

H-** 

*•••"  THEN  3010  'MAKE  THEM  LOG  ON  FIRST 

01 B5 

0026 

CLOSE  1 

01BC 

0026 

018C 

0026 

REH  READ  PASSWORD 

AND  DECRYPT 

01BC 

0026 

OPEN  "I",1,"RACFP«O.FEX" 

01CE 

0026 

IF  EOFd)  THEN 

3010 

010C 

0026 

INPUT  #1,PWS 

01EB 

002A 

CLOSE  1 

01F2 

002A 

USER$(2)="" 

01FB 

002A 

FOR  1=1  TO  6 

0202 

002A 

USERS(2}=USER$(2}KHR$(ASC(HID$(PUS,7-I,1))-17+I) 

0227 

002C 

NEXT  I 

0236 

J02C 

0236 

002C 

KEY  (1)  ON 

0230 

002C 

KEY  (10)  ON 

0244 

002C 

SCREEN  0,1, 0,0 

025A 

002C 

COLOR  FORE, BACK, BORO 

0270 

002C 

CLS 

0274 

002C 

REM  PAGE  2  -  THE  1 

PLEASE  WAIT  SCREEN 

0274 

002C 

SCREEN  ,,2 

0281 

002C 

CLS 

0285 

002C 

GOSU6  7000 

'PRINT  HEADING 

028A 

002C 

LOCATE  12,25 

0297 

002C 

PRINT  "PLEASE 

WAIT  ...  PROGRAM  LOADING" 

029F 

0-120 
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029F 

002C 

029F 

002C 

029F 

002C 

02B1 

002C 

02B5 

002C 

02BA 

002C 

02BA 

002C 

02BA 

002C 

02BA 

002C 

02BA 

002C 

02BA 

002C 

02BA 

002C 

02BA 

002C 

02BA 

002C 

02BA 

002C 

02BA 

002C 

02BA 

002C 

028A 

002C 

02BA 

002C 

02BA 

002C 

02BA 

002C 

02C8 

0030 

0207 

0030 

02DF 

0030 

02E7 

0030 

02EF 

0030 

02F7 

0030 

02FF 

0030 

0307 

0030 

C30F 

0030 

0317 

0030 

031 F 

0030 

0327 

0030 

032F 

0030 

0337 

0030 

033F 

0030 

0347 

0030 

034F 

0030 

0357 

0030 

0357 

0030 

0364 

0030 

036C 

0030 

0379 

0030 

0379 

0030 

0379 

0030 

0379 

0030 

0379 

0030 

038B 

0030 

0394 

0030 

03AF 

0030 

03B6 

0030 

03B6 

0030 

0387 

0030 

03C9 

0030 

REM 

REM  PUT  THE  MAIN  MENU  ON  PAGE  0  WHILE  DISPLAYING  PAGE  2 
SCREEN  ,,0,2 
CLS 

GOSUB  7000  'PRINT  HEADING 

REM  SINCLUDE:  'RACSIO.MOV  'INCLUDE  THE  MAIN  MENU 

REM  ♦ . + 

REM  I  NAME:  RACS10.M01  RACS10:  MAIN  MENU  | 

REM  I  DATE:  27  AUG  86  WRITTEN  BY:  0  R  BOLLING  j 

REM  . . . 

REM  This  screen  is  the  main  menu  used  in  the  opening  program. 

REM  Macro  level  functions  are  displayed  and  selected  from  this  screen. 
REM 

REM  REMINDER:  The  first  ttra  lines  of  display  are  reserved  for  the 
REM  heading,  and  the  last  three  lines  are  reserved  for  selection  input, 
REM  error  display  and  function  display. 

REM 

REM  User  menus  are  restricted  to  lines  3-21. 

REM  . START  OF  MAIN  MENU  SELECTION . 

R0U>3:C0L>1  'Starting  ROW  and  COLUMN  for  sienu  display 
LOCATE  ROW, COL 


PRINT 

r 

PRINT 

1  MAIN  MENU  1" 

PRINT 

1 

1 

1 

T" 

PRINT 

N 

1  Option 

Description 

1 

Option  Description 

1" 

PRINT 

N 

1 

1 

\" 

1 

PRINT 

N 

1  A  ... 

START  OPTICAL  NARK  READER 

1 

F  ...  FUTURE  APPLICATION 

1- 

PRINT 

M 

1 

1 

1" 

PRINT 

H 

1  B  ... 

COPY  VISIT.OAT  TO  0  DRIVE 

1 

G  ...  FUTURE  APPLICATION 

1" 

PRINT 

H 

1 

1 

1" 

PRINT 

II 

1  C  ... 

COPY  PATIENT.DAT  TO  0 

1 

H  ...  FUTURE  APPLICATION 

1- 

PRINT 

11 

1 

1 

1" 

PRINT 

II 

1  D  ... 

COPY  PROVIDER. OAT  TO  D 

1 

I  ...  FUTURE  APPLICATION 

1" 

PRINT 

II 

1 

1 

1" 

PRINT 

II 

1  E  ... 

FUTURE  APPLICATION 

1 

X  ...  EXIT 

I" 

PRINT 

H 

1 

1 

1" 

DDiyT 

N 

1 _ 

_l_ 

1  M 

LOCATE  20,1 

PRINT  "  Enter  Option  - - 

LOCATE  20,40 

REM  . END  OF  MAIN  MENU  SELECTION-- 


REM  UPDATE  THE  FILE 
OPEN  "O",1,"RACLOG.0AT" 

PID$="RACP10" 

WRITE  «1,USER$(1), DATES, TIMES, PIDS 
CLOSE  1 

600  REN  OPEN  THE  COMMON  BATCH  FILE  AND  INITIALIZE  IT 
OPEN  "O",!, "RACB00.BAT" 


RACP10 

Initial  Setection  Screen 


'■  Offset 

Oata 

Source  Line 

03C9 

0030 

700 

REM  SWAP  BACK  TO  THE  MENU  SCREEN  (PAGE  0) 

07CA 

0030 

SCREEN  .,0 

0306 

0030 

LOCATE  20,40 

03E3 

0030 

03E3 

0030 

705 

GOSUB  2000  'REPLY  FUNCTION 

03E8 

0030 

03ES 

0030 

710 

REM  DECODE  THE  ENTRY 

03E9 

0030 

VALIDS^MABCDEFGHIX" 

03F2 

0034 

BRANCH>INSTR  (VALIDS.REPLYS) 

0400 

003A 

IF  BRANCH  3  0  THEN  GOSUB  4000  :  LOCATE  20,40  :  GOTO  705 

0421 

003A 

ON  BRANCH  GOSUB  800,810,820,830,835,840,845,850,860,870 

0430 

003A 

GOTO  700 

0441 

003A 

0441 

003A 

800 

REM  FUNCTION  'A' . OMR 

0442 

003A 

CLOSE  :  CLS 

044A 

003A 

CHAIN  "RACPIA" 

0451 

003A 

0451 

003A 

810 

REM  FUNCTION  'B' . 

0452 

003A 

PRINT  #1,“CLS“ 

0450 

003A 

PRINT  «1,''ECHO  ON" 

0468 

003A 

PRINT  «1,»REM  PLACE  IOMEGA  CARTRIDGE  IN  DRIVE  D" 

0473 

003A 

PRINT  #1,"REM  " 

047E 

003A 

PRINT  #1,«REM  VISIT.DAT  FILE  WILL  BE  COPIED  TO  DRIVE  D« 

0489 

003A 

PRINT  «1,"REM  AND  RENAMED  TO  VISIT.OLD  ON  DRIVE  C" 

f  ^  0494 

003A 

PRINT  #1,"REM  " 

V-  049F 

003A 

PRINT  #1,"REM  " 

04AA 

003A 

PRINT  #1, "PAUSE" 

04B5 

003A 

PRINT  )|f1,"ECHO  OFF" 

04C0 

003A 

PRINT  #1,"COPY  VISIT.DAT  D:VISIT.DAT" 

04C8 

003A 

PRINT  #1,"IF  EXIST  VISIT.OLD  ERASE  VISIT.OLD" 

0406 

003A 

PRINT  #1, "RENAME  VISIT.DAT  VISIT.OLD" 

04E1 

003A 

PRINT  #1,"CLS" 

04EC 

003A 

PRINT  #1,"RACB10" 

04F7 

003A 

GOTO  9999 

04FB 

003A 

RETURN 

04FE 

003A 

04FE 

003A 

820 

REM  FUNCTION  'C 

04FF 

003A 

PRINT  #1,"CLS" 

050A 

003A 

PRINT  #1,"ECHO  ON" 

0515 

003A 

PRINT  «1,"REH  PLACE  IOMEGA  CARTRIDGE  IN  DRIVE  D" 

0520 

003A 

PRINT  #1,"REM  " 

052B 

003A 

PRINT  #1,"REM  PATIENT. OUT  FILE  WILL  BE  COPIED  TO  DRIVE  D" 

0536 

003A 

PRINT  «1,"REM  AND  RENAMED  TO  PATIENT .OLD  ON  DRIVE  C" 

0541 

003A 

PRINT  #1,"REH  " 

054C 

003A 

PRINT  #1,"REM  " 

0557 

003A 

PRINT  #1, "PAUSE" 

0562 

003A 

PRINT  #1,"ECHO  OFF" 

0560 

003A 

PRINT  #1,"COPY  PATIENT.DAT  D:PATIENT.OUT" 

0578 

003A 

PRINT  #1, "RENAME  PATIENT.DAT  PATIENT. OLD" 

0583 

003A 

PRINT  #1,"CLS" 

058E 

003A 

PRINT  #1,"RACB10" 

0599 

003A 

GOTO  9999 

0590 

003A 

0590 

003A 

830 

REM  FUNCTION  'O' 
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B59E  003A  PRIMT  #1,"CLS" 

05A9  003A  print  #1,"ECH0  0N“ 

05B4  003A  PRINT  #1,"REM  PLACE  IOMEGA  CARTRIDGE  IB  DRIVE  D" 

05BF  003A  print  #1,"REM  “ 

05CA  003A  PRINT  «1,"REM  PROVIDER. OUT  FILE  WILL  BE  COPIED  TO  DRIVE  D" 

0505  003A  print  #1,»REM  AND  RENAMED  TO  PROVIDER. OLD  ON  DRIVE  C" 

05EO  003A  PRINT  «1,"REM  " 

05EB  003A  PRINT  OI.-REM  " 

05F6  003A  PRINT  #1, "PAUSE" 

0601  003A  PRINT  «1."ECHO  OFF" 

060C  003A  PRINT  #1,"COPY  PROVIDER. OAT  D:PROVIDER.OUT" 

0617  003A  print  #1, "RENAME  PROVIDER.DAT  PROVIDER. OLD" 

0622  003A  PRIMT  #1,"CLS" 

0620  003A  PRIMT  «1,"RACB10" 

0638  003A  GOTO  9999 

063C  003A 

063C  003A  835  REN  FUNCTION  'E' 

0630  003A  GOTO  700 

0641  003A 

0641  003A  840  REN  FUNCTION  'F' 

0642  003A  GOTO  700 

0646  003A 

0646  003A  845  REM  FUNCTION  'G' 

0647  003A  GOTO  700 

064B  003A 

064B  003A  850  REM  FUNCTION  'H' 

064C  003A  GOTO  700 

0650  003A 

0650  003A  860  REM  FUNCTION  M' 

0651  003A  GOTO  700 

0655  003A 

0655  003A  870  REM  FUNCTION  'X'  EXIT 

0656  003A  GOTO  3010 

065A  003A 

065A  003A 

065A  003A  2000  REM  REPLY  FUNCTION 

065B  003A  2020  REPLY$= INKEYS  :  IF  REPLY$=""  THEN  2020 

066F  003A  REPLY=ASC(REPLY$) 

0679  003C  IF  REPLY  >  90  THEN  REPLY$=CHR$(REPLY  XOR  32)  'CONVERT  TO  CAPS 

0694  003C  IF  REPLYS  <  "A"  OR  REPLYS  >  "Z"  THEN  REPLY$="?" 

06C0  003C  RETURN 

06C3  003C 

06C3  003C  3000  REM  PF  KEY  TRAPS 

06C4  003C 

06C4  003C  3001  REN  PF  1  =  HELP 

06C5  003C  SCREEN  ,,1 

0602  003C  LOCATE  24,40 

06OF  003C  GOSUB  2000  'REPLY  FUNCTION 

06E4  003C  RETURN  700 

06EA  003C 

06EA  003C  3002  REM  PF  2  =  UNUSED 

06EB  003C  KEY  (2)  OFF 

06F2  003C  RETURN  700 

06F8  003C 


DISABLE  PF  KEY 


RACPIO 

Initial  Salaction  Screen 


'■  offset 

Data 

Source  Line 

06F8- 

003C 

3003 

REH  PF  3  *  UNUSED 

06F9 

003C 

KEY  (3)  OFF 

0700 

003r 

RETURN  TOO 

0706 

003C 

0706 

003C 

3004 

REM  PF  4  s  UNUSED 

0707 

003C 

KF.Y  (4)  OFF 

OTOE 

0d3C 

RETURN  700 

0714 

003C 

0714 

003C 

3005 

REM  PF  5  <  UNUSED 

0715 

003C 

KEY  (5)  OFF 

071C 

003C 

RETURN  700 

0722 

003C 

0722 

003C 

3006 

REN  PF  6  s  UNUSED 

0723 

003C 

KEY  (6)  OFF 

072A 

003C 

RETURN  700 

0730 

003C 

0730 

003C 

3007 

REM  PF  7  =  UNUSED 

0731 

003C 

KEY  <7)  OFF 

0738 

003C 

RETURN  700 

073E 

003C 

073E 

003C 

073E 

003C 

3008 

REN  Pf  8  =  UNUSED 

073F 

003C 

KEY  (8)  OFF 

0746 

003C 

RETURN  700 

074C 

■ —  fl7Lr  ' 

003C 

003C 

3009 

REM  PF  9  *  UNUSED 

0740 

003C 

KEY  (9)  OFF 

0754 

003C 

RETURN  700 

075A 

003c 

075A 

003C 

3010 

REM  PF10  =  LOGOFF,  RE! 

075B 

003C 

SCREEN  ,,0 

0767 

003c 

CLOSE 

0760 

003C 

OPEN  ■•O^^,1/^RACLOG.OAT' 

0770 

003C 

CLOSE 

0781 

003c 

OPEN  ••O^^ ,  1 ,  ••R ACBOO .  BAT ' 

0793 

003C 

CLOSE 

0797 

003c 

CHAIN  ■•RACP05^^ 

079E 

003C 

END 

07A2 

003c 

07A2 

003c 

4000 

REM  ERROR  ON  SELECTION 

07A3 

003C 

LOCATE  21,1 

07BO 

003C 

COLOR  EFORE,EBACK 

07BF 

003C 

FOR  I  =  1  TO  3 

07C6 

003C 

SOUND  523.25,1.5 

07D0 

003C 

SOUND  800.5,1.5 

07DA 

003C 

NEXT 

07E9 

003C 

PRINT  •■  ERROR  :  ••,-REPL 

07FB 

003c 

FOR  I  =  1  TO  3000 

0802 

003c 

NEXT  I 

0812 

003c 

LOCATE  21,1 

081 F 

003C 

COLOR  FORE, BACK 

082E 

003c 

PRINT  SPC(79) 

0837 

003C 

RETURN 

003C 

■DISABLE  PF  KEY 


■DISABLE  PF  KEY 


■DISABLE  PF  KEY 


■DISABLE  PF  KEY 


■DISABLE  PF  KEY 


•DISABLE  PF  KEY 


•DISABLE  PF  KEY 
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083A 

003C 

7000 

REM  PRINT  THE  HEADING  ON  THE 

SCREEN 

083B 

003C 

REM 

SINCLUDE:  • RACSTOOO . SUB <  INCLUDE  THE  STANDARD  HEADER 

0838 

003C 

PEP 

****** 

083B 

003C 

REM 

**** 

AMBULATORY  CARE  DATA 

BASE  13  APR  85 

**** 

083B 

003C 

REM 

**** 

SKIP  COLE 

**** 

083B 

003C 

REM 

SUBROUTINE  NAME 

RACSTOOO. SUB 

**** 

083B 

003C 

REM 

SCANNER  PROGRAM  « 

ALL 

**** 

083B 

003C 

REM 

*«*« 

FUNCTION 

THIS  SUBROUTINE  MODULE 

**** 

083B 

003C 

REM 

**** 

PRINTS  THE  STANDARD  SCREEN 

***• 

083B 

003C 

REM 

***« 

HEADING. 

**** 

083B 

003C 

REM 

INPUT 

COMMON  VARIABLE  USER$(2) 

**** 

083B 

003C 

REM 

SYSTEM  DATE 

**** 

083B 

003C 

REM 

**** 

083B 

003C 

REM 

***• 

OUTPUT 

SCREEN  HEADING 

**** 

083B 

003C 

REM 

**** 

**** 

083B 

003C 

REM 

RESERVED  LINE 

**** 

083B 

003C 

REM 

**** 

NUMBERS 

7001-7010 

**** 

083B 

003C 

REM 

****** 

083B 

003C 

083B 

003C 

7001 

LOCATE 

1.1 

0845 

003C 

PRINT 

"U.S.  ARMY  AMBULATORY  CARE  INFORMATION  SYSTEM" 

084D 

003C 

LOCATE 

1,65 

085A 

003C 

PRINT 

DATES; 

0862 

003C 

LOCATE 

2.1 

086F 

003C 

PRINT 

"USER  :  ";USERS(1) 

087C 

003C 

RETURN 

087F 

003C 

087F 

003C 

9999 

REM  EXIT  TO  THE  BATCH  FILE 

0880 

003C 

CLS 

0884 

003C 

SCREEN 

..0 

0890 

003C 

CLOSE 

0894 

003C 

END 

0898  003C 

089B  003C 

22151  Bytes  Available 
18557  Bytes  Free 


0  Warning  Error(s) 
0  Severe  Error(s) 
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iffset 

Data 

Source  Line 

IBM  Personal  Coisputer  BASIC  Compiler  VI. 00 

001A 

0002 

REH  SLINESIZE:  132 

001A 

0002 

REM  SPAGESIZE:  66 

001A 

0002 

REH  STITLE:  'RACPIA  < 

001A 

0002 

REM  SSUBTITLE:  'OMR  PROGRAM  SELECT  ' 

001A 

0002 

REM  SPAGE 

f 


RACP1A 

ON*  noGRAM  SELECT 
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001A 

0002 

001A 

0002 

001A 

0002 

001A 

0002 

001A 

0002 

001A 

0002 

001A 

0002 

001A 

0002 

001A 

0002 

001A 

0002 

001 A 

0002 

001A 

0002 

OOIA 

0002 

001A 

0002 

OOIA 

0002 

?01A 

0002 

OOIA 

0002 

OOIA 

0002 

OOIA 

0002 

OOIA 

0002 

OOIA 

0002 

OOIA 

0002 

OOIA 

0002 

OOIA 

0002 

OOIA 

0002 

OOIA 

0002 

OOIA 

0002 

OOIA 

0002 

OOIA 

0002 

OOIA 

0002 

OOIA 

0002 

OOIA 

0002 

OOIA 

0002 

OOIA 

0002 

OOIA 

0002 

OOIA 

0002 

OOIA 

0002 

OOIA 

0002 

001A 

0002 

OOIA 

0002 

OOIA 

0002 

OOIA 

0002 

OOIA 

0002 

OOIA 

0002 

OOIA 

0002 

OOIA 

0002 

OOIA 

0002 

OOIA 

0002 

OOIA 

0002 

OOIA 

0002 

OOIA 

0002 

OOIA 

0002 

OOIA 

0002 

OOIA 

0002 

DEFINT  A-Z 

REM  + . ♦ 

REH  I  NAME:  RACP1A  AMBULATORY  CARE  INFORMATION  SYSTEM  | 

REM  I  DATE;  31  MAR  87  RE  WRITTEN  BY:  D.R. BOLLING  j 

REM  . . . 

REM  PATIENT  OMR  INPUT  PROGRAM 

REM 

REM  This  program  reads  the  OMR  HEADER  from  the  first  record  and 

REH  calls  the  proper  program  for  decoding . 

REM 

REM  . 

REM  SINCLUDE:  •RACDIH.MOO*  REH  INCLUDE  THE  DIMENSION  DEFINITIONS 


NAME:  RACDIM.HOD  DIMENSION  DEFINITIONS 

Date:  28  Feb  84  Written  by:  Floyd  Cole 


Dimensioned  variables  are  defined  in  this  file. 

It  is  an  included  file  so  it  cannot  be  run  in  a  stand-alone, 
mode. 

This  program  segment  may  be  modified,  but  all  files  containing 
an  include  for  this  segment  must  be  re-compiled  in  order  to 
affect  the  changes  made  here. 

***•••*•***•  start  OF  DIMENSION  DEFINITION  •****•*•*••••*•***•*• 


DEFINT  A-Z 

DIM  USERSv2),HOLENGTH<12),DATEERRS(3) 

•*•**••**••*  end  OF  DIMENSION  DEFINITIONS  *•*••*•••**••*•*•*•** 


DIM  SHEETREC(1750)  '(MAX.  SIZE  FOR  A  SHEET  FROM  THE  SCANNER) 

DIM  PROTOCOL(7)  '(ARRAY  FOR  SERIAL  BOARD  SETUP  PARAMETERS) 

REM  SINCLUDE:  'RACCMN.HOO'  REM  INCLUDE  THE  COMMON  AREA  DEFINITION 


NAME:  RACCMN.MOD  COMMON  AREA  DEFINITION 

Date:  28  Feb  84  Written  by:  Floyd  Cole 


COMMON  AREA  DEFINITIONS  WILL  BE  HELD  IN  THIS  FILE.  IT  IS  AM 
INCLUDED  FILE  SO  IT  CANNOT  BE  RUN  IN  A  STANO*ALONE,  MODE. 

This  program  segment  may  be  modified,  but  all  files  containing 
an  include  for  this  segment  must  be  re*compiled  in  order  to 
affect  the  changes  made  here. 


START  OF  COMMON  DEFINITIONS' 


COMMON 

COMMON 

COMMON 

COMMON 

COMMON 

COMMON 


FORE , BACK , BOARD , H I DE , E  FORE , EBACK , BELLS 


HEADERS 
TEXTS 
PGM IDS 
MOLENGTHO 
USERS( ) 


<21  CHARACTER  SCANNER 
■  ■  AIMING  CHARACTERS 
■PROGRAM  OR  FORM  ID 
■DAYS  IN  THE  MONTH 


'BASIC  SCREEN  COLORS 
HEADER  INFO 
FROM  SCANNER 


RACP1A 

CNR  PROGMN  SFLECT 
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001 A  0002 

001A  0002 

0G1A  0002 
001A  0002 

001A  0002 

OOlA  0002 
001A  0002 

OOlA  0002 
001A  0002 

001A  0002 

OOlA  0002 
OOlA  0002 
OOlA  0002 
001A  0002 

001A  0002 

001 A  0002 

OOlA  0002 
OOlA  0002 
OOlA  0002 
OOlA  0002 
0040  OODO 
0047  OODO 
004E  0002 

0055  0002 

005C  0002 

•  0063  0002 

006F  0002 

006F  0002 

0076  0002 

0070  0002 

0084  0002 

0088  0002 
0092  0002 

0099  0002 

OOAO  0002 
00A7  0002 

OOAE  0002 
00B5  0002 

OOBC  0002 
00C3  0002 

00C3  0002 

OOCC  0002 
0005  0002 

OOOE  0002 
00E7  0002 

0067  0002 

OOEE  0004 
OOF 7  0008 

00F7  0008 

00F7  0008 

00F7  0008 

OOF 7  0008 

OOFO  0008 
OOFO  ODDS 


'END  OF  COMMON  DEFINITION' 


REM  SINCLUDE:  •RACOEF.MOD*  REM  INCLUDE  THE  DEFAULT  DEFINITIONS 


NAME:  RACP01.DEF  DEFAULT  DEFINITIONS 

Date:  28  Feb  84  Written  by:  Floyd  Cole 

r***************************»***********************************1 

Variables  used  in  coonnn  that  have  a  default  value  on  start*up 
will  be  held  in  this  file.  It  is  an  included  file  so  it  cannot 
be  run  in  a  stand*slone  mode.  In  normal  operation^  this  file 
should  be  'included*  in  the  main  program  only  (RACP10.BAS). 

This  program  segment  may  be  modified,  but  all  files  containing 
an  include  for  this  segment  must  be  re*cofflpiled  in  order  to 
affect  the  changes  made  here. 


'START  OF  DEFAULT  DEFINITION’ 


FORE  =  15 

■FOREGROUND  COLOR  =  INTENSE  WHITE 

BACK  =  1 

'Background  Color  =  Light  Blue 

BORO  3  4 

•BORDER 

=  RED 

HIDE  =  4 

■ALTERNATE 

;  COLOR  -  RED 

£FOfiE=  14 

•ERROR  FOREGROUND  DISPLAY 

E8ACK-  0 

•ERROR  BACKGROUND  DISPLAY 

BELLS  =  CHRS(7) 

■Sound  the  bell 

MOLENGTH(I) 

r 

31 

•JAN 

MOLENGTH(2) 

= 

28 

•FEB  <--NOOIFtED  IN  SUBROUTINE  RACS5000 

MOLENGTH(3) 

- 

31 

•MAR 

MOLENGTH(4) 

= 

30 

•APR 

MOLENGTH(5) 

31 

•MAY 

MOLENGTH(6} 

30 

•JUN 

MOLEHGTH(7) 

= 

31 

•JUL 

MOLENGTH(8) 

= 

31 

■AUG 

MOLENGTH{9) 

= 

30 

■SEP 

MOLENGTHdO) 

= 

31 

•OCT 

MOLENGTH(II) 

= 

30 

•NOV 

MOLENGTH<12) 

= 

31 

•DEC 

DATEERRSIO) 

s 

II  II 

DATEERRSd) 

= 

"INVALID 

MONTH" 

0ATEERRS(2) 

= 

"INVALID 

DAY  •■ 

DATEERRS(3) 

= 

"DAY  TOO 

LARGE  FOR  MONTH  COOED" 

MAXLENGTH 

80 

•MAXIMUM  LENGTH  OF  OUTPUT  RECORD 

PADS 

= 

1.  II 

•PAO  CHARACTER  FOR  SHORT  RECORDS 

*»**»**»****»END  OF  DEFAULT  DEFINITION' 


KEY  OFF 

REM  LENGTH  OF  STRING  RECEIVED  FROM  THE  OMR.... 
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Offset  Data  Source  Line  IBM  Personal  CoafXJter  BASIC  Conpiler  VI .00 

OOFD  OOD8  HEADER  -  21 

0104  ODDA  RECORDLENGTH  °  HEADER 

010B  OODC 

010B  OODC  REM  . 

010B  ODOC  REM  PAGE  1  -  THE  SCREEN  HEADER 

010B  OODC  REM  . 

010B  OODC  20  CLS 

010F  OODC  COLOR  14 

0116  OODC  LOCATE  12,25  :  PRINT  START  THE  SCANNER  ■* 

012B  OODC  LOCATE  15,25  :  PRINT  ••  PRESS  ANY  KEY  TO  BEGIN _  " 

0140  OODC 

0140  OODC  GOSUB  200G  'DELAY 

0145  OODC 

0145  OODC  REM  *•*•*****•****•**»•**••••»***»»*»**»**»**»*•******•*»»»»*»»•»*»»»»• 

0145  OODC  REM  ****  COMMUNICATIONS  SETUP 

0145  OODC  REM  ******•****•*••**•*****•*****•**••***•••**•*•**•******************* 

0145  OODC  REM 

0145  OODC  GOSUB  9001 

OKA  ODOC  IF  ERRMSGS  >  »  »  THEN  LPRINT  ERRMSGS  :  GOTO  30000 

0164  ODEO 

0164  ODEO  REM  *****••*•**•••*••*•*••••******•********•************•*********•*•** 

0164  ODEO  REM  ****  START  THE  SCANNER 

0164  ODEO  REM  ****••••••*•****••••**•***•*••**••**••***•••**••*************•***** 

0164  ODEO 

0164  ODEO  CNTRLOPT  =1  :GOSUB  9010  'SI  -  START  THE  READER 

0170  00E2  IF  ERRMSGS  >  "  "  THEN  LPRINT  ERRMSGS  :  GOTO  30000 

018A  OOE2 

018A  OOE2  REM 

018A  OOE2  REM  •***  SET  SCAN  SHEET  CALL  •••• 

018A  OOE2  REM  **•*********•***•*****•****•♦*******•***•*•**•••**••********••***** 

018A  OOE2  REM 

018A  0DE2 

018A  OOE2  200  REM  -  FIRST  SHEET  TRANSMIT  . 

0188  0DE2 

018B  OOE2  READTYPE  =  2 

0192  OOE4  GOSUB  9020  'SCAN  SUBROUTINE 

0197  0DE4  IF  MIOSCERRSTATS, 14,3)  =  "415"  GOTO  25000 

01B3  ODES 

01 B3  00E8  REM  ******************************************************************* 

01B3  OOE8  REM  ****  DECODE  THE  HEADER  •*** 

01 B3  OOE8  REM  *******•**************••*******♦**•*•.*******.*************•*..**** 

01B3  0DE8  210  REM 

01B4  OOE8  TEXTS*""  'CLEAR  THE  INPUT  AREA 

0180  OOE8  RECOROPTR  =  VARPTR(SKEETREC(0)) 

01 C4  ODEA  TOT  *  0 

01CB  ODEC  HEADERS*"" 

0104  ODEC  FOR  JA1  *  1  TO  RECORDLENGTH 

01E1  OOEE  TEXTS*  TEXTS+CHRS(PEEK(RECORDPTR  ♦  TOT)) 

01FF  OOEE  TOT=TOT+1 

0207  OOEE  NEXT  JA1 

0218  ODFO 

0218  ODFO  PROGRAMS*  LEFTS(TEXTS,3) 

0227  00 F4  PGM I OS*  PROGRAMS 

0230  00F4  BATCHS*  MIDS(TEXTS,4,3) 


RACP1A 
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(• 


.ffset 

Data 

Source 

Line 

IBM  Personal  Conputer  BASIC  Compiler  VI. 00 

0242 

0OF8 

SERIALS*  MI0S(TEXTS.7,4) 

0254 

OOFC 

RUNIDS* 

MIDS(TEXTS,11,1} 

0268 

OEOO 

FORMS* 

MI0S<TEXTS.12.2} 

0278 

0E04 

POCKETS= 

MIDS(TEXTS.14.1) 

C28A 

0E08 

SCANERR1S*MIDS(TEXTS, 16,2) 

029C 

OEOC 

SCANERR2S*MIDS(TEXTS,18,2) 

02AE 

0E10 

SCANERR3S*M 1 DS( TEXTS, 20. 2) 

02C0 

0E14 

02C0 

0E14 

REM 

02C0 

0E14 

REM 

**** 

WHAT  PROGRAM  IS 

IT?? 

**** 

02C0 

0E14 

REM 

**« 

**s 

02C0 

0E14 

02;0 

0E14 

IF 

PROGRAMS  * 

••200“ 

GOTO  320 

•PATIENT  REGISTRATION 

0202 

0E14 

IF 

PROGRAMS  * 

••210“ 

GOTO  325 

•QUALITY  CONTROL 

PROG 

02E4 

0E14 

IF 

PROGRAMS  * 

"300“ 

GOTO  330 

•PROVIDER  REGISTRATION 

02F6 

0E14 

IF 

PROGRAMS  * 

11400 •< 

GOTO  400 

•ENCOUNTER 

FORM 

ADOLESCENT  NED 

0308 

0E14 

IF 

PROGRAMS  * 

"410“ 

GOTO  400 

•ENCOUNTER 

FORM 

ALLERGY 

031A 

0E14 

IF 

PROGRAMS  * 

"420“ 

GOTO  400 

•ENCOUNTER 

FORM 

AUDIOLOGY/SPEE 

032C 

0E14 

IF 

PROGRAMS  * 

"430“ 

GOTO  400 

•ENCOUNTER 

FORM 

CARDIOLOGY 

033E 

0E14 

IF 

PROGRAMS  * 

"440“ 

GOTO  400 

•ENCOUNTER 

FORM 

CARDIOTHORACIC 

0350 

0E14 

IF 

PROGRAMS  * 

"450“ 

GOTO  400 

•ENCOUNTER 

FORM 

DERMATOLOGY 

0362 

0E14 

IF 

PROGRAMS  * 

••460“ 

GOTO  400 

•ENCOUNTER 

FORM 

ENDOCRINE 

0374 

0E14 

IF 

PROGRAMS  = 

"470“ 

GOTO  400 

•ENCOUNTER 

FORM 

ENT 

0386 

0E14 

IF 

PROGRAMS  * 

»480'* 

GOTO  400 

•ENCOUNTER 

FORM 

FAMILY  MED 

0398 

0E14 

IF 

PROGRAMS  * 

“490^^ 

GOTO  400 

•ENCOUNTER 

FORM 

GASTROENTEROLO 

03AA 

0E14 

IF 

PROGRAMS  * 

"500" 

GOTO  400 

•ENCOUNTER 

FORM 

GENERAL  SURC 

03BC 

0E14 

IF 

PROGRAMS  * 

"510“ 

GOTO  400 

•ENCOUNTER 

FORM 

GYNECOLOGY 

03CE 

0E14 

IF 

PROGRAMS  * 

“520“ 

GOTO  400 

•ENCOUNTER 

FORM 

INFECTIOUS  DIS 

03E0 

0E14 

IF 

PROGRAMS  * 

"530" 

GOTO  400 

•ENCOUNTER 

FORM 

INTERNAL  NED 

03F2 

0E14 

IF 

PROGRAMS  * 

'•540^^ 

GOTO  400 

•ENCOUNTER 

FORM 

NEPHROLOGY 

0404 

0E14 

IF 

PROGRAMS  = 

"550" 

GOTO  400 

•ENCOUNTER 

FORM 

NEUROLOGY 

0416 

0E14 

IF 

PROGRAMS  * 

"560“ 

GOTO  400 

•ENCOUNTER 

FORM 

NEUROSURGERY 

0428 

0E14 

IF 

PROGRAMS  * 

"570" 

GOTO  400 

•ENCOUNTER 

FORM 

NUCLEAR  MED 

043A 

0E14 

IF 

PROGRAMS  * 

“580" 

GOTO  400 

•ENCOUNTER 

FORM 

NUTRITION 

044C 

0E14 

IF 

PROGRAMS  = 

“590" 

GOTO  400 

•ENCOUNTER 

FORM 

OBSTETRICS 

045E 

0E14 

IF 

PROGRAMS  = 

"600" 

GOTO  400 

•ENCOUNTER 

FORM 

ONCOLOGT/HEM 

0470 

0E14 

IF 

PROGRAMS  = 

••610" 

GOTO  400 

•ENCOUNTER 

FORM 

OPHTHAMOLOGY 

0482 

0E14 

IF 

PROGRAMS  * 

>•620" 

GOTO  400 

•ENCOUNTER 

FORM 

OPTOMETRY 

0494 

0E14 

IF 

PROGRAMS  * 

••630" 

GOTO  400 

•ENCOUNTER 

FORM 

ORTHO  APPL 

04A6 

0E14 

IF 

PROGRAMS  * 

"640" 

GOTO  400 

•ENCOUNTER 

FORM 

ORTHOPEDICS 

04B8 

0E14 

IF 

PROGRAMS  * 

"650^' 

GOTO  400 

•ENCOUNTER 

FORM 

OCCUPAT  THER 

04CA 

0E14 

IF 

PROGRAMS  * 

"660" 

GOTO  400 

■ENCOUNTER 

FORM 

PAIN/PHYS  MED 

040C 

0E14 

IF 

PROGRAMS  * 

"670" 

GOTO  400 

•ENCOUNTER 

FORM 

PEDIATRICS 

04EE 

0E14 

IF 

PROGRAMS  = 

"680" 

GOTO  400 

•ENCOUNTER 

FORM 

PHYS  THERAPY 

0500 

0E14 

IF 

PROGRAMS  * 

■•690'^ 

GOTO  400 

•ENCOUNTER 

FORM 

PLASTIC  SUR 

0512 

0E14 

IF 

PROGRAMS  * 

••700" 

GOTO  400 

•ENCOUNTER 

FORM 

PODIATRY 

0524 

0E14 

IF 

PROGRAMS  * 

"710" 

GOTO  400 

•ENCOUNTER 

FORM 

PREV  MED 

0536 

0E14 

IF 

PROGRAMS  * 

"720" 

GOTO  400 

•ENCOUNTER 

FORM 

PRIMARY  CARE 

0548 

0E14 

IF 

PROGRAMS  * 

"730" 

GOTO  400 

•ENCOUNTER 

FORM 

PSYCHIATRY 

055A 

0E14 

IF 

PROGRAMS  * 

"740" 

GOTO  400 

■ENCOUNTER 

FORM 

PSYCHOLOGY 

056C 

0E14 

IF 

PROGRAMS  * 

••750" 

GOTO  400 

•ENCOUNTER 

FORM 

PULMONARY 

057E 

0E14 

IF 

PROGRAMS  * 

••760" 

GOTO  400 

•ENCOUNTER 

FORM 

RADIOTHERAPY 

0590 

OEH 

IF 

PROGRAMS  = 

••770^' 

GOTO  400 

■ENCOUNTER 

FORM 

RHEUMATOLOGY 

05A2 

0E14 

IF 

PROGRAMS  = 

"780'^ 

GOTO  400 

•ENCOUNTER 

FORM 

SOCIAL  WORK 

RACP1A 

OMR  PROGRAM  SELECT 


Offset  Data 


05B4 

0E14 

05C6 

0E14 

0508 

0E14 

05EA 

0E14 

05FC 

0E14 

060E 

0E14 

0620 

0E14 

0632 

0E14 

0644 

0E14 

0656 

0E14 

0668 

0E14 

067A 

0E14 

068C 

0E14 

069E 

0E14 

06B0 

0E14 

06C2 

0E14 

0604 

0E14 

06E6 

0E14 

06E6 

0E14 

06FB 

0E14 

070D 

0E14 

0715 

0E14 

071D 

0E14 

0722 

0E14 

0726 

0E14 

0726 

0E14 

0726 

0E14 

072E 

0E14 

0735 

0E14 

0735 

0E14 

0730 

0E14 

0744 

0E14 

0744 

0E14 

074C 

0E14 

0753 

0E14 

0753 

0E14 

075B 

0E14 

0762 

0E14 

0762 

OEH 

076A 

0E14 

0771 

0E14 

0771 

OEH 

0779 

0E14 

0780 

OEH 

0780 

0E14 

0788 

OEH 

078F 

OEH 

078F 

OEH 

0797 

OEH 

079E 

OEH 

079E 

OEH 

07A6 

OEH 

07AO 

OEH 

07AO 

OEH 

PAGE  6 
08-03-87 

Line  07:15:42 

IBM  Personal  Conputer  BASIC  Coa*)iler  vl.OO 

IF  PROGRAMS  =  “790«  GOTO  400  ‘ENCOUNTER  FORM  ..  UROLOGY 

IF  PROGRAMS  =  "800"  GOTO  800  'ENCOUNTER  FORM  ..  BAS/THC 

IF  PROGRAMS  =  "810"  GOTO  810  'ENCOUNTER  FORM  ..  EFMP 

IF  PROGRAMS  »  "820"  GOTO  820  'ENCOUNTER  FORM  ..  EKG 

IF  PROGRAMS  =  "830"  GOTO  830  'ENCOUNTER  FORM  ..  EMERGENCY  RM 

IF  PROGRAMS  =  "840"  GOTO  840  'ENCOUNTER  FORM  ..  CROUP  I 

IF  PROGRAMS  =  "850"  GOTO  850  'ENCOUNTER  FORM  ..  GROUP  II 

IF  PROGRAMS  =  "860"  GOTO  860  'ENCOUNTER  FORM  ..  IMMUNIZ  SHORT 

IF  PROGRAMS  =  "870“  GOTO  870  'ENCOUNTER  FORM  ..  I MR 

IF  PROGRAMS  =  "880"  GOTO  880  'ENCOUNTER  FORM  ..  INHALATION  TH 

IF  PROGRAMS  =  "890"  GOTO  890  'ENCOUNTER  FORM  ..  NUTRITION  SHOR 

IF  PROGRAMS  =  "900"  GOTO  900  'ENCOUNTER  FORM  ..  OCCUP  HEALTH 

IF  PROGRAMS  =  "910“  GOTO  910  'ENCOUNTER  FORM  ..  OCCUP  THER  RPT 

IF  PROGRAMS  =  "920"  GOTO  920  'ENCOUNTER  FORM  ..  PHYS  TH  REPEAT 

IF  PROGRAMS  =  "930“  GOTO  930  'ENCOUNTER  FORM  ..  REPEAT 

IF  PROGRAMS  =  “940"  GOTO  940  'ENCOUNTER  FORM  ..  SHORT 

IF  PROGRAMS  =  "950"  GOTO  950  'ENCOUNTER  FORM  ..  SOC  UORK  SHORT 

CLS  :  LOCATE  12,10  :  BEEP 

PRINT  "PROGRAM  ".-PROGRAMS;"  IS  NOT  A  VALID  CODE.." 

PRINT  "  MAKE  SURE  YOU  HAVE  LOADED  THE  FORMS  CORRECTLY.." 

PRINT  "  PRESS  ANY  KEY  TO  RETURN  TO  THE  MAIN  MENU  . " 

GOSUB  2000 
GOTO  30000 


320  CLS  :  CLOSE 

CHAIN  "RACP200"  'PATIENT  REGISTRATION 

325  CLS  :  CLOSE 

CHAIN  "RACPVER"  <qC  VERIFICATION  PROGRAM 

330  CLS  :  CLOSE 

CHAIN  "RACP300"  'PROVIDER  REGISTRATION 

400  CLS  :  CLOSE 

CHAIN  "RACPGEN"  'GENERAL  FORM  PROGRAM 

800  CLS  :  CLOSE 

CHAIN  "RACP800"  ' BAS/THC  FORM  PROGRAM 

810  CLS  :  CLOSE 

CHAIN  "RACP810"  'EFMP  FORM  PROGRM1 

820  CLS  ;  CLOSE 

CHAIN  "RACP820"  >EKG  FORM  PROGRAM 

830  CLS  :  CLOSE 

chain  "RACP830"  'EMERGENCY  ROOM  PROGRAM 

840  CLS  :  CLOSE 

CHAIN  "RACP840" 

850  CLS  :  CLOSE 


'GROUP  I  FORM  PROGRAM 


RACP1A 
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Jffset 

Data 

Source  Line 

ISM  Personal  Computer  SASIC  Conpiler  VI .00 

0785 

OEU 

CHAIN 

“RACP850" 

•GROUP  II  FORM  PROGRAM 

07BC 

OEU 

078C 

OEU 

860 

CLS  : 

CLOSE 

07C4 

OEU 

CHAIN 

••RACP860'' 

•IMMUNIZATION  SHORT  FORM  PROG 

0708 

OEU 

07C8 

OEU 

870 

CLS  : 

CLOSE 

0703 

OEU 

CHAIN 

"RACP870'' 

•IHR  FORM  PROGRAM 

070A 

OEU 

07DA 

OEU 

880 

CLS  : 

CLOSE 

07E2 

OEU 

CHAIN 

•■RACP880" 

•INHALATION  THERAPY  FORM  PROG 

07E9 

OEU 

07E9 

OEU 

890 

CLS  : 

CLOSE 

07F1 

OEU 

CHAIN 

"RACP890" 

•NUTRITION  CARE  FORM  PROGRAM 

07F8 

OEU 

07F8 

OEU 

900 

CLS  : 

CLOSE 

0800 

OEU 

CHAIN 

"RACP900" 

•OCCUPATIONAL  HEALTH  FORM  PROGRAM 

0807 

OEU 

0807 

OEU 

910 

CLS  : 

CLOSE 

080F 

OEU 

CHAIN 

“RACP910" 

•OCCUPATIONAL  THERAPY  PROGRAM 

0816 

OEU 

0816 

OEU 

920 

CLS  : 

CLOSE 

081E 

OEU 

CHAIN 

“RACP920" 

•PHYS  THERAPY  FORM  PROGRAM 

0825 

OEU 

0825 

OEU 

930 

CLS  ; 

CLOSE 

0820 

OEU 

CHAIN 

“RACP930'' 

•REPEAT  FORM  PROGRAM 

*0834 

OEU 

0834 

OEU 

940 

CLS  : 

CLOSE 

083C 

OEU 

CHAIN 

"RACP940" 

•SHORT  FORM  PROGRAM 

0843 

OEU 

0843 

OEU 

950 

CLS  : 

CLOSE 

0848 

OEU 

CHAIN 

"RACP950" 

•SOCIAL  WORK  SHORT  FORM  PROGRAM 

0852 

OEU 

0852 

OEU 

REM 

END  OF 

SCAN/OECOOE/URITE 

LOOP  ====.=====================.=====.===== 

0852 

OEU 

0852 

OEU 

0852  0E14  2000 

0853  0E14  REM 

0853  0E14  REM 

0853  OEU  REM 

0853  OEU  REM 

0853  OEU  REM 

0853  OEU  REM 

0853  OEU  REM 

0853  OEU  REM 

0853  OEU  REM 

0853  OEU  REM 

0853  OEU  REM 

0853  OEU  REM 

0853  C'^U  REM 

0853  OEU  REM 

0853  OEU  REM 

0853  OEU  2001 

0854  OEU  2002 

0868  0E18 
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0872 

0E1A 

IF  REPLY  >  90  THEN  REPLYS^^CHRSl REPLY  XOR  32)  'CONVERT  TO  CAPS 

0880 

0E1A 

IF  REPLYS  <  "A"  OR  REPLYS  > 

“2"  THEN  REPLYS*"?" 

08B9 

0E1A 

RETURN 

08BC 

0E1A 

08BC 

0E1A 

9000 

REM  SINCLUDE:  ■RACS9000.SUB 

INCLUDE  THE  SCANNER  CONTROL  SUBS 

0880 

0E1A 

REM 

******************************************************************* 

08BO 

0E1A 

REM 

****  AMBULATORY  CARE  DATA  BASE  13  APR  85 

**** 

08BD 

0E1A 

REM 

**** 

SKIP  COLE 

**** 

0880 

0E1A 

REM 

****  PROGRAM  NAME 

:  RACS9000.SLI8 

**** 

oaao 

0E1A 

REM 

****  SCANNER  PROGRAM  « 

ALL 

**** 

0880 

0E1A 

REM 

FUNCTION 

THIS  SUBROUTINE  HQOULE 

***• 

0880 

0E1A 

REM 

**** 

CONTROLS  THE  SCANNER  I/O 

***• 

0880 

0E1A 

REM 

**** 

0880 

0E1A 

REM 

*•**  INPUT/OUTPUT 

REFER  TO  THE  ASYNCHRONOUS 

**** 

0880 

0E1A 

REM 

**** 

COMMUNICATIONS  MANUAL  AND  THE 

**** 

0880 

0E1A 

REM 

PRE- RELEASED  SOFTWARE  GUIDE 

**** 

0880 

0E1A 

REM 

*•*« 

**** 

0880 

0E1A 

REM 

0880 

0E1A 

REM 

RESERVED  LINE 

***• 

0880 

0E1A 

REM 

••••  NUMBERS 

:  9001-9100 

**** 

0880 

0E1A 

REM 

***** 

0880 

0E1A 

0880 

0E1A 

0880 

0E1A 

REM 

0880 

0E1A 

REM 

***•  SUBROUTINE  9001  -  PROTOCOL  SETUP  FOR  SCANNER 

0880 

0E1A 

REM 

***•  ARGUMENTS:  PRESET  ... 

SEE  BELOU 

0880 

0E1A 

REM 

0880 

0E1A 

9001 

REH 

088E 

0E1A 

PROTOCOL(O)  =  9600 

■BAUD  RATE 

08C5 

0E1A 

PROTOCOL(I)  =  78 

•PARITY  (SEE  PAGE  4-8  OF  MANUAL) 

08CC 

0E1A 

PR0T0C0L(2)  =  8 

•DATA  BITS 

0803 

0E1A 

PR0T0C0L<3)  =  1 

•STOP  BITS 

080A 

0E1A 

PROTOCOL (4)  =  2 

'RS-232  PORT 

08E1 

0E1A 

PR0T0C0L(5)  =  0 

•WRITE  TIME- OUT 

08E8 

0E1A 

PR0T0C0L(6)  =  0 

•READ  TIME-OUT 

08EF 

0E1A 

08EF 

0E1A 

ERRSTATS  =  SPACE$(60) 

08FB 

0E1A 

ARGPTR  =  VARPTR(PROTOCOL(0)) 

0902 

0E1C 

CALL  SETUP  (ARGPTR, ERRSTATS) 

0913 

0E1C 

ERRMSGS="" 

091C 

0E1C 

IF  ASC(ERRSTATS)  <>  64  THEN  ERRMSG$=“SETUP  ERROR  "♦ERRSTATS 

0938 

0E1C 

GOTO  9100 

093C 

0E1C 

093C 

0E1C 

REH 

093C 

0E1C 

REM 

***•  SUBROUTINE  9010  -  CONTROL  OPTIONS  FOR  SCANNER 

093C 

0E1C 

REH 

••••  ARGUMENTS:  CNTRLOPT 

093C 

0E1C 

REM 

CNTRLOPT  =  1  =  START 

SCANNER  (SI) 

093C 

0E1C 

REM 

****  CNTRLOPT  =  2  =  STOP 

SCANNER  (SO) 

093C 

0E1C 

REM 

****  CNTRLOPT  =  3  *  TERMINATE  COMMUNICATIONS  TO  SCANNER  (DC3) 

093C 

0E1C 

REM 

****  CNTRLOPT  =  4  =  CLEAR 

TRANSPORT  PATH  (0C2) 

093C 

0E1C 

REH 

**•*  CNTRLOPT  =  5  =  SELECT 

PRIMARY  STACKER  "31" 

093C 

0E1C 

REM 

CNTRLOPT  =  6  =  SELECT 

SECONDARY  STACKER  "32" 

093C 

0E1C 

REM 

••••  CNTRLOPT  =  7  =  POSITIVE  RESPONSE/SELECT  SCANNER  (DC1) 

***** 

093C 

0E1C 

REH 

*•**  CNTRLOPT  =  8  =  REQUEST  STATUS  (ESC) 

RACPIA 

cm  PtOOUM  SELECT 
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offset  Data  Source  Line  IBM  Personal  Coaputer  BASIC  Conpiler  VI .00 


093C 

093C 

OEIC 

OEIC 

REN 

9010 

REN 

0930 

OEIC 

ERRSTATS  >  SPACES(60) 

0949 

OEIC 

CALL  CNTROL  (CNTRLOPT, ERRSTATS) 

C95A 

OEIC 

ERRNSGSx"" 

0963 

OEIC 

IF  ASC(ERRSTATS)  <>  64  THEN  ERRMSGSx"CONTROL  ERROR  "♦ERRSTATS 

097F 

OEIC 

GOTO  9100 

0983 

OEIC 

0983 

OEIC 

REM 

*«*«*«**********•«***•*******•***********•«««*«**•**•**♦*•********* 

0983 

OEIC 

REM 

SUBROUTINE  9020  -  SCAN  SHEET  CALL 

0983 

OEIC 

REM 

0983 

OEIC 

REM 

****  ARGUMENTS:  REAOTYPE 

0983 

OEIC 

REM 

REAOTYPE  X  2  X  REQUEST  NEW  OOCUMEHT  FROM  SCANNER 

0983 

OEIC 

REN 

REAOTYPE  X  3  X  RETRANSMIT  CURRENT  DOCUMENT 

0983 

OEIC 

REM 

**** 

0983 

OEIC 

REM 

•***  ARGUMENTS:  RECORDLENGTH 

0983 

OEIC 

REN 

****  NUMERIC  VARIABLE  SET  TO  THE  NUMBER  OF  CHARACTERS  TO  BE 

0983 

OEIC 

REM 

TRANSMITTED 

0983 

OEIC 

REM 

0983 

OEIC 

9020 

REM 

0984 

OEIC 

ERRSTATS  x  SPACES(60) 

0990 

OEIC 

RECORDPTR  X  VARPTR(SHEETREC(0)) 

0997 

OEIC 

CALL  SCAN  (REAOTYPE. RECOROLENGTN.RECORDPTR.ERRSTATS) 

0980 

OEIC 

ERRMSGSx"" 

0989 

OEIC 

IF  MI0S<ERRSTATS,14,3)  «  "415“  THEN  ERRMS0Sx"ESC" 

090A 

OEIC 

GOTO  9100 

09DE 

OEIC 

090E 

OEIC 

REM 

090E 

OEIC 

REM 

SUBROUTINE  9030  -  TRANSPORT  PRINT  CALL 

***** 

09DE 

OEIC 

REN 

090E 

OEIC 

REN 

*•••  ARGUMENTS:  PRIHTPOS 

090E 

OEIC 

REM 

**♦*  NUMERIC  VARIABLE  INDICATING  THE  STARTING  PRINT  POSITION 

090E 

OEIC 

REN 

*•**  VALUES  X  0  THRU  90 

090E 

OEIC 

REM 

***** 

090E 

OEIC 

REM 

ARGUMENTS:  PSTRINGS 

***** 

090E 

OEIC 

REM 

*•••  TEXT  TO  BE  PRINTED  ON  THE  FORM 

090E 

OEIC 

REM 

**** 

09DE 

OEIC 

REM 

NOTE:  THIS  ROUTINE  HAS  HO  EFFECT  UNLESS  THE  SCAN 

***** 

090E 

OEIC 

REM 

HEADER  SHEET  IS  MARXEO  'PRINTER  ON' 

09DE 

OEIC 

REM 

CI9DE  0E1C  9030  REM 


090F  OEIC  ERRSTATS  =  SPACES(60) 

09EB  OEIC  RECORDPTR  -  VARPTR(SHEETREC(0}) 

09F2  OEIC  CALL  TPRINT(PRINTPOS,PSTRINGS,ERRSTATS) 

0A07  0E22  IF  ASC(ERRSTATS)  <>  64  THEN  ERRMSGSx"PR|NT  ERROR  "^ERRSTATS 

0A23  0E22  GOTO  9100 

0A27  0E22 

0A27  0E22  9100  RETURN 

0A2A  0E22  REM . END  OF  SUBROUTINE  RACS9000,SUB . 

0A2A  0E22 

0A2A  0E22  25000  REM  USER  TERMINATEO  INPUT 

0A2B  0E22  CLS  :  BEEP 

0A33  0E22  LOCATE  14,28:PRINT  "PROGRAM  TERMINATEO  BY  USER" 

0A48  0E22 
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Offset 

Data 

Source  Line 

IBM  Personal  Computer  BASIC  Compiler  VI. 00 

0A48 

0E22 

30000  REM 

0A49 

0E22 

CLOSE 

0A40 

0E22 

CHAIN  »RACP10>< 

0A5A 

0E22 

0A57 

0E22 

221S1  Bytes  Avai lable 
18526  Bytes  Free 


0  Warning  Error(s) 
0  Severe  Error(s) 


APPENDIX  D 


APPENDIX  D 


CLINIC. MAS 
CLINICl.FEX 
CLINIC2 . FEX 
CLINIC3 . FEX 
CLINIC4 . FEX 
DEERS . FEX 
DIAGDMP.FEX 
DIAGNOS.MAS 
LOADCLIN . FEX 
LOADDIAG.FEX 
LOADOTH.FEX 
LOADPROC . FEX 
MAIN. FEX 
MILTl.FEX 
MILT2 . FEX 
MILT3 . FEX 
OTHER. MAS 
PATIENT. MAS 
PROCDMP.FEX 
PROCEDUR.MAS 
PROFILE . FEX 
PROVl . FEX 
PROV2 . FEX 
PROV3 . FEX 
PROV4 . FEX 
PROVIDER. MAS 
RPTCRT . FEX 
RPTCRTl.FEX 
RPTCRT2 . FEX 
RPTCRT 3 . FEX 
RPTCRT4 . FEX 
RPTCRT5 . FEX 
RXXCCLD.FEX 
RXXCORL.FEX 
RXXCPAD.FEX 
RXXCPRD.FEX 
RXXF200.FEX 
RXXF300.FEX 
RXXF400.FEX 
RXXFCCL.FEX 
RXXFCPA.FEX 
RXXFCPR.FEX 
RXXFDCL.FEX 
RXXFDPA.FEX 
RXXFDPR.FEX 


PC  FOCUS  PROCEDURES 
TABLE  OF  CONTENTS 


Clinic  Master  file  PC 
Report  1  Provider  by  Clinic 
Report  2  Patient  Cat  by  Clinic 
Report  3  Referral  Source 
Report  9  Job  related 
DEERS  Special  Load  PC 
Diagnosis  Description  Dump  PC 
Diagnosis  Master  file  PC 
Clinic  Description  Load  PC 
Diagnosis  Description  Load  PC 
Other  Code  Description  Load  PC 
Procedure  Description  Load  PC 
Main  menu  program  PC 
Report  10  Military  Unit 
Report  11  Unit  Health 
Report  12  (unfinished) 

Other  Codes  Master  file  PC 
Patient  Master  file  PC 
Procedure  Description  Dump  PC 
Procedure  Master  file  PC 
FOCUS  Initialization  file  PC 
Report  4  Provider  Diagnosis 
Report  5  Provider  Procedure 
Report  6  Provider  Time/Status 
Report  7  Provider  Dx  by  Clinic 
Provider  Master  file  PC 
Selection  Menu  for  Rpts  1-6 
Selection  Menu  for  Rpts  7,8 
Selection  Menu  for  Rpts  10 
Selection  Menu  for  Rpts  11 
Selection  Menu  for  Rpts  12 
Selection  Menu  for  Rpts  9 
Clinic  Correction  Dump  PC 
Loads  Corrected  file  to  Visit 
Patient  Correction  Dump  PC 
Provider  Correction  Dump  PC 
Patient  Load  file  PC 
Provider  Load  file  PC 
Visit  Load  file  PC 
Control  Clinic  Correction  PC 
Control  Patient  Correction  PC 
Control  Provider  Correction  PC 
Clinic  Dump  file  PC 
Patient  Dump  file  PC 
Provider  Dump  file  PC 


RXXFDVI.FEX  Visit  Dump  file  PC 
VISIT. MAS  Visit  Master  file  PC 


CLINIC. MAS 


FILENAME=CLINIC, SUFFIX=FOC 
SEGNAME=CLINIC, SEGTYPE=S1 

FIELDNAME=CLIMIC,  ALIAS=CLUCA,  FORMAT=A4 ,  FIELDTYPE=I, 

FIELDNAME=CL_TITLE,  ALIAS=302CLTITLE,  FORMAT=A20  , 

FIELDNAME=CL_302CODE,  ALIAS=302CLCODE,  F0RMAT=A2  , 

FIELDNAME=CL_302LINE,  ALIAS=302CLLINE,  F0RMAT=I3  , 

END 

DBA=LUGNUT,$ 

USER=NUTMEG,  ACCESS=RW,  $ 


</></> -CXA 


-*  * 
-*  PROGRAM;  CLINICl.FEX  MODIFIED:  6/17/87  DRB  * 
-*  FOR  NEW  DESIGN  * 

-*  REPORT:  1  MENU  PROGRAM:  RPTCRT.FEX  * 

* 

-****************************************************** 

-* 

-SET  &&RPT=' ENCOUNTERS  PER  PROVIDER  PER  CLINIC  COUNT'; 

EX  RPTCRT 

-RUN 

-IF  &&RTN  EQ  'X'  THEN  GOTO  RTN  ELSE  GOTO  CONT; 

-RTN 

-EXIT 

-CONT 

-IF  &&NITE  EQ  'Z'  THEN  GOTO  ASET  ELSE  GOTO  CONTI; 

-ASET 

-SET  &&ST=&ST; 

-SET  &&END=&END; 

-SET  &&CLN=&CLN; 

-SET  &&PROV=&PROV; 

-CONTI 

JOIN  PROV_ID  IN  VISIT  TO  PROV_ID  IN  PROVIDER  AS  JOINl 
JOIN  CLINIC  IN  VISIT  TO  CLINIC  IN  CLINIC  AS  JOIN2 
TABLE  FILE  VISIT 
HEADING  CENTER 

"  ENCOUNTERS  PER  PROVIDER  PER  CLINIC  COUNT" 

"  FOR  &&ST  TO  &&END  </2" 

SUM  CNT  LITHO  AS  'VISIT, COUNT'  IN  60 
VISIT_CNT/I6  AS  'WEIGHTED, COUNT'  IN  70 
BY  CLINIC  AS  'CLINIC,  CODE' 

BY  CL_TITLE  AS  'CLINIC  TITLE'  IN  10 
BY  PROV_ID  AS  'PROVIDER,  ID.'  IN  35 
BY  PROV_LST_NME  AS  'LAST  NAME*  IN  45 
IF  CLINIC  EQ  &&CLN 
IF  VISIT_DATE  FROM  &&ST  TO  &&END 
IF  PROV_ID  EQ  &&PROV 

ON  CLINIC  SUBTOTAL  AS  'TOTAL  VISITS  FOR  CLINIC 

ON  CLINIC  PAGE-BREAK 

END 

JOIN  CLEAR  * 

-RUN 


1 


I 

I 


— -kit  It  It  left  *  1:1111  hit  It  •k-k-k  1c -k-kle -kit  hit  It  h  hick  h -kit  It  It  1111111111  ifk-k-kii -kit  hit  Ic  It  ic  hie 
-h  h 

-*  PROGRAM:  CLINIC2.FEX  MODIFIED:  6/17/87  DRB  * 

-*  FOR  MEW  DESIGN  * 

-*  REPORT:  2  MENU  PROGRAM:  RPTCRT.FEX  * 

—  4c  k 

—hhhhhhhhhhhkkhhkhhkkhhhkkhhhhkhhhhhhhkhhhhhhhhkkhhhhh 
-h 

-SET  &&RPT  =  'PATIENT  CATEGORY  BY  CLINIC; 

EX  RPTCRT 
-RUN 

-IF  &&RTN  EQ  'X'  GOTO  RTN  ELSE  GOTO  CONT; 

-RTN 

-EXIT 

-CONT 

-IF  &&NITE  EQ  'Z'  THEN  GOTO  ASET  ELSE  GOTO  CONTI; 

-ASET 

-SET  &&ST=&ST; 

-SET  &&END=&END; 

-SET  &&CLN=&CLN; 

-SET  &&PROV=&PROV; 

-CONTI 

JOIN  CLINIC  IN  VISIT  TO  CLINIC  IN  CLINIC  AS  JJOIN 
JOIN  PTID  IN  VISIT  TO  PTID  IN  PATIENT  AS  JJOINl 

DEFINE  FILE  VISIT 

WN/A7=IF  PT_CATEGORY  EQ  '  '  THEN  'NONE'  ELSE  PT_CATEGORY; 

END 

TABLE  FILE  VISIT 
HEADING  CENTER 

"PATIENT  CATEGORY  BY  CLINIC" 

"FOR  <CL_TITLE" 

"FROM  &&ST  TO  &&END  </2" 

COUNT  LITHO_CODE  AS  ' PATIENT, COUNT '  IN  85 

BY  CLINIC  IN  35  BY  CL_TITLE  AS  '  CLINIC,  NAME  '  IN  45 

BY  WN  AS  'PATIENT, CATEGORY'  IN  70 

IF  CLINIC  EQ  &&CLN 

IF  VISIT_DATE  FROM  &&ST  TO  &&END 

IF  FNUM  NE  '84' 

ON  CLINIC  SUBTOTAL  PAGE-BREAK 
FOOTING  CENTER 

"NONE  INDICATES  THOSE  PATIENTS  ARE  NOT  REGISTERED." 

END 

JOIN  CLEAR  * 

-RUN 


I 

I 


i 


i 


I 


•  i 


I 


I 


I 


I 


—  *****************  hlfklt  ****************************  Ifk*** 

* 

PROGRAM:  CLINIC3.FEX  MODIFIED:  6/17/87  DRB  * 

FOR  NEW  DESIGN  * 

REPORT:  3  MENU  PROGRAM:  RPTCRT.FEX  * 

* 

—****************************************************** 

-* 

-SET  &&RPT=' REFERRAL  SOURCE  AND  PLACE  OF  VISIT'; 

-RUN 

EX  RPTCRT 
-RUN 

-IF  &&RTN  EQ  'X'  GOTO  RTN  ELSE  GOTO  CONT; 

-RTN 

-EXIT 

-CONT 

-IF  &&NITE  EQ  'Z'  THEN  GOTO  ASET  ELSE  GOTO  CONTI; 

-ASET 

-SET  &&ST=&ST; 

-SET  &&END=&END; 

-SET  &&CLN=&CLN; 

-SET  &&PROV=&PROV; 

-CONTI 

JOIN  CLINIC  IN  VISIT  TO  CLINIC  IN  CLINIC  AS  JOINl 

-INCLUDE  DCODE2 

-RUN 

DEFINE  FILE  VISIT  ADD 

(•  CLTITLE/A20=IF  CL_TITLE  EQ  '  '  THEN  CLINIC  ELSE  CL_TITLE; 

END 

TABLE  FILE  VISIT 

SUM  CNT  LITHO  COLUMN-TOTAL  AS  •  NUMBER,  OF , ENCOUNTERS '  IN  25 

VISIT_CNT/I6  COLUMN-TOTAL  AS  'WEIGHTED, NO.  OF , ENCOUNTERS '  IN  3 
BY  CLINIC  NOPRINT 

BY  CLTITLE  AS  '  CLINIC  NAME  ' 

BY  INP_REFERAL  AS  'REFERRAL,  SOURCE'  IN  73 
BY  VIS_PLACE  AS  '  PLACE  OF  VISIT  '  IN  49 
IF  CLINIC  EQ  &&CLN 
IF  VISIT_DATE  FROM  &&ST  TO  &&END 
HEADING  CENTER 

"REFERRAL  SOURCE  AND  PLACE  OF  VISIT  </l" 

"FROM  &&ST  TO  &&END" 

END 

JOIN  CLEAR  * 

-RUN 


-* 

-* 

-* 

-* 
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-*********************************************************** 
—  *  * 

-*  PROGRAM:  CLINIC4.FEX  MODIFIED;  1/14/86  DRB  * 

— *  * 

-*  REPORT:  9  MENU  PROGRAM;  RPTCRT5.FEX  * 

— *  * 

_*********************************************************** 
-* 

-SET  &&RPT='JOB  RELATED  REPORT'; 

EX  RPTCRT5 
-RUN 

-IF  &&RTN  EQ  'X'  GOTO  RTN  ELSE  GOTO  CONT; 

-RTN 

-EXIT 

-CONT 

-IF  &&NITE  EQ  'Z'  THEN  GOTO  ASET  ELSE  GOTO  CONTI; 

-ASET 

-SET  &&ST=&ST; 

-SET  &&END=&END; 

-SET  &&CLN=&CLN; 

-CONTI 

-SET  &ST=EDIT(&&ST, '99/99/99 •) ; 

-SET  &END=EDIT(&&END, '99/99/99') ; 

-RUN 

JOIN  DIAGl_CODE  IN  VISIT  TO  DGNCD  IN  DIAGNOS  AS  JOINl 
JOIN  CLINIC  IN  VISIT  TO  CLINIC  IN  CLINIC  AS  JOIN2 
TABLE  FILE  VISIT. JOBREL 
HEADING  CENTER 

"</2  JOB  RELATED  REPORT" 

"FOR  &ST  TO  &END  </2" 

PRINT  PATIENT_ID  AS  'PATIENT  ID.'  IN  35 

DIAG_DESCR  AS  '  DIAGNOSIS  DESCRIPTION 

BY  CLINIC  IN  25 

IF  CLINIC  EQ  &&CLN 

IF  VISIT_DATE  FROM  &&ST  TO  &&END 

IF  JOBREL  EQ  Y 

ON  CLINIC  PAGE-BREAK 

END 

JOIN  CLEAR  * 

-RUN 


_* - 

-* 

-*  PROCEDURE  DEERS. FEX  PREPARED  BY  D.R.B 

-*  ON  11/18/86 

-*  LOADS  THE  PATIENT  DATA  BASE  FROM  DEERS  DATA 
DATA  IS  IN  FILE  ' PATIENT . OUT • 

-*  RECORDS  WITH  DUPLICATE  SSN  NUMBERS  ARE  REJECTED 
_* - - - 

SET  MORE=OFF 

FILEDEF  RXXF200  DISK  E : PATIENT . OUT 
USE 

D: PATIENT. FOC 
END 

MODIFY  FILE  PATIENT 

TYPE  AT  START  "PATIENT  LOAD  PROCEDURE  IN  PROGRESS" 

FIXFORM  PTID/Cll  PTDOB/C6  CATEG/A3 
FIXFORM  PTLITHO/C8 

FIXFORM  REGDATE/C6  SEX/Cl  RACE/Cl  PREFIX/C2  PAYGRADE/C2 
FIXFORM  JOBCODE/C4  PTLOC/C6  TRAINEE/Cl  VA/Cl  HCI/Cl 
FIXFORM  ZIP/C5  PTDUALSSN/C9  PTFORGN/C3 
MATCH  PTID 

ON  NOMATCH  INCLUDE 
ON  MATCH  REJECT 
CHECK  OFF 
DATA  ON  RXXF200 
END 


(• 
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DIAGDMP.FEX 


-CRTCLEAR 
-TYPE 
-TYPE 
-TYPE 
-TYPE 
-TYPE 
-TYPE 
-TYPE 
-TYPE 
-READ  SYS IN 
-CRTCLEAR 
-TYPE 

-TYPE  PREPARATION  OF  FT.  DETRICK  BERNOULLI  DIAGNOSIS  FILE 
-TYPE 

-TYPE  IN  PROGRESS 

-TYPE 

USE  C: SITE. IDF 
END 

FILEDEF  SITEF  DISK  C: SITE. IDF 
-RUN 

-SET  &&SITE=' 

-READ  SITEF  &&SITE 
USE 

DiDIAGNOS.FOC 
E:DETDIAG.FTM  NEW 

END 

FILEDEF  DETR  DISK  E : DETDIAG . FTM 
-SET  ALL=ON; 

DEFINE  FILE  DIAGNOS 
SITE/A4='&&SITE' ; 

END 

-RUN 

-TYPE  DIAGNOSIS  RECORDS  BEING  PROCESSED 

TABLEF  FILE  DIAGNOS 

PRINT  SITE  SEG.DGNCD 

ON  TABLE  SAVE  AS  DETR 

END 

-RUN 


DIAGNOS. FOC  DUMP  PROGRAM 

PREPARE  BERNOULLI  CARTRIDGE  FOR  SHIPMENT  TO  FT.  DETRICK 

1.  PLACE  NEWLY  FORMATED  CARTRIDGE  IN  DRIVE  E. 

2.  DRIVE  D  SHOULD  CONTAIN  DIAGNOS. FOC  FILE  (STANDARD). 

HIT  ENTER  TO  CONTINUE 
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DIAGNOS.MAS 


FILENAME=DIAGNOS , SUFFIX=FOC 
SEGNAME=DIAGNOS , SEGTYPE=S1 

FIELDNAME=DIAG_CODE,  ALIAS=DGNCD,  FORMAT=A5, 

FIELDNAME=DIAG_DESCR,  ALIAS=DGNDSC ,  FORMAT=A50 

END 

DBA=LUGNUT,$ 

USER=NUTMEG,  ACCESS=RW,  $ 


FIELDTYPE=I ,  $ 


* - 

* 

*  PROCEDURE  LOADCLIN 

* 

*  LOADS  THE  CLINIC  DATA  BASE 

*  DATA  IS  IN  FILE  'BAMCOP.PRN' 

* 

* - 

FILEDEF  LOADCLIN  DISK  ArBRAGOP.PRN 
USE 

D: CLINIC. FOC 
END 

-CRTCLEAR 

MODIFY  FILE  CLINIC 

FIXFORM  X6  CLUCA/C4  CL_TITLE/C20 

MATCH  CLINIC 

ON  NOMATCH  INCLUDE 
ON  MATCH  CONTINUE 
DATA  ON  LOADCLIN 
END 


1 


—  1c1i1fk1t1fk'k‘k1fk1fk1i1t1t1i1e'lt1fk1t1e1e1fk1t1fk1fk1fk1t1fk1fk1fk1t1c‘k1c1c1fk1fk1i1c'k1i1c1fk'k1fk1i 

~*  MAIN.FEX  MAIN  FOCUS  DATA  BASE  MENU  * 

-*  * 

“*  MODIFIED  4/14/86  D  R  BOLLING  * 

-*  MODIFIED  5/7/86  DRB  CORRECT  RPT6  LABEL  * 

-*  MODIFIED  12/16/86  DRB  SYSTEM  TO  BE  ON  C  DRV* 

SET  PAUSE=OFF 
SET  COLOR=ON 

SET  BACK=BLUE,FORE=IWHITE 

SET  MSG=OFF 

SET  PRINT=OFFLINE 

USE 

DzPROCEDUR.FOC 
DzDIAGNOS.FOC 
D: CLINIC. FOC 
D; PATIENT. FOC 
D: PROVIDER. FOC 
E; VISIT. FOC 
END 


-RUN 

-SECTIONl 
-CRTCLEAR 
-SET  &MSG=' 
-SET  &REPLY=' 
-MAIN 
-CRTFORM 


•  If 


AMBULATORY  CARE  DATA  MANAGEMENT  SYSTEM 


PLEASE  SELECT  A  PROCESS 


A  . 
B  . 
C  . 
D  . 
E  . 


.  Load  Patient  Registration 
.  Load  Provider  Registration 
.  Load  Encounter  Forms 
.  Correct  Data  Base 
.  Prepare  Ft.  Detrick  Shipment 

X  . .  LOGOFF 


F 

G 

H 

I 

J 


.  File  Maintenance 
.  Tabletalk  -  Report  S 
.  Rebuild  Patient/Prov 
.  Rebuild  Encounter  Fi 
.  Standard  Reports  Opt 


ENTER  YOUR  SELECTION .  <  .  IRHW .  &REPLY  <77 

<.H.YELL.D.&MSG  <77  |" 


-SET  &DEST=DECODE  &REPLY  (A  PTLOAD  B  PRLOAD  C  ENLOAD  D  CORRECT 

E  SHIPMENT  F  MAINT  G  REPORT  H  PRREBLT  I  ENREBLT  J  SCRIT  X  LOGOFF 
ELSE  NOPE) ; 

-GOTO  &DEST 
-PTLOAD 


1 


-CRTFORM 

n 

PLACE  CARTRIDGE  WITH  PATIENT. OUT  FILE  IN  E  DRIVE” 

_it  II 

HIT  ENTER  TO  CONTINUE” 

-TYPE  "PLEASE  WAIT  -  PROGRAM  LOADING” 

EX  RXXF200 
-RUN 

-CRTFORM 

_ii  II 

-"  REPLACE  CARTRIDGE  WITH  VISIT. FOC  FILE  IN  E  DRIVE” 

_ii  _  _  _  II 

_ii  II 

-”  HIT  ENTER  TO  CONTINUE" 

-RUN 

-GOTO  SECTIONl 

-PRLOAD 

-CRTFORM 

_ii  II 

-”  PLACE  CARTRIDGE  WITH  PROVIDER. OUT  FILE  IN  E  DRIVE” 

_ii  II 

-"  HIT  ENTER  TO  CONTINUE" 

-TYPE  "PLEASE  WAIT  -  PROGRAM  LOADING” 

EX  RXXF300 
-RUN 

-CRTFORM 

_ii  II 

-”  REPLACE  CARTRIDGE  WITH  VISIT. FOC  FILE  IN  E  DRIVE" 

_ii  _  _  _ii 

_ii  II 

-”  HIT  ENTER  TO  CONTINUE” 

-RUN 

-GOTO  SECTIONl 
-ENLOAD 

-TYPE  "PLEASE  WAIT  -  PROGRAM  LOADING" 

EX  RXXF400 
-RUN 

DOS  ERASE  D: VISIT. OUT 
-RUN 

-GOTO  SECTIONl 
-MAINT 
FILETALK 
-RUN 

-GOTO  SECTIONl 
-REPORT 
TABLETALK 
-RUN 

-GOTO  SECTIONl 
-PRREBLT 
EX  RXXPTREB 
-RUN 

EX  RXXPRREB 


-RUN 

-GOTO  SECTIONl 
-ENREBLT 
EX  RXXENREB 
-RUN 

-GOTO  SECTIONl 
-NOPE 

-SET  &MSG  =  'INCORRECT  SELECTION  ENTERED.  PLEASE  TRY  AGAIN'; 
-GOTO  MAIN 
-LOGOFF 
-GOTO  EXIT 

-******************  REPORT  MENU  ****************************** 
-SCRIT 

-SET  &MSG  =  •  ' ; 

-SET  &PRT  =  ' 1 ' ; 

-SET  &SEL  =  •  ' ; 

-SET  &&RPT  =  '  ' ; 

-SET  StSTITLE  =' REPORT  SELECTION  MENU'; 

-SET  &&NITE  =  'N'; 

-* 


-SECTION2 

-CRTFORM 


_n 

_n 

.11 

—  H 

—  M 

_ll 

_»• 

_« 

_« 


AMBULATORY  CARE  DATA  MANAGEMENT  SYSTEM 


<.H.A.D.fiiSTITLE  <77  || " 


1  -  ENCOUNTERS  BY  PROV.  BY  CLINIC 

2  -  PATIENT  CATEGORY 

3  -  CLINIC  REFERRAL  SOURCES 

4  -  PROVIDER  DIAGNOSIS  REPORT 

5  -  PROVIDER  PROCEDURE  REPORT 

6  -  TIME  AND  APPT  STATUS 
N  -  STACK  NIGHT  REPORTS 


7  -  NUMBER  VISITS  IN  ALL  CLINIC 

8  -  PROVIDER  DIAGNOSIS  FOR  ALL 

9  -  JOB  RELATED  REPORT 

10  -  MILITARY  UNIT  REPORT 

11  -  HEALTH  UNIT  REPORT 

12  -  CLINIC  ACTIVITY  REPORT 
X  -  EXIT  TO  PREVIOUS  MENU 


ENTER  REPORT  OPTION  (1  =  SCREEN  2  =  PRINTER):  <.IR^{WT.&PRT  <77 
ENTER  SELECTION;  <.IRHW.&SEL  <77  1| " 

<.H.YELL.D.&MSG  <77  ||" 


-SET  &DESl=DECODE  &PRT  (1  ONIT  2  OFFIT  ELSE  BADSEL) ; 

-GOTO  &DES1 
-GOODSEL 

-SET  &DEST=DECODE  &SEL  (1  RPTl  2  RPT2  3  RPT3  4  RPT4  5  RPT5  6  RPT6 
7  RPT7  8  RPT8  9  RPT9  10  RPTIO  11  RPTll  12  RPT12  N  TONIGHT 
X  SECTIONl  ELSE  BADSEL) ; 

-GOTO  &DEST 
-BADSEL 

-SET  &MSG  =  'INCORRECT  SELECTION  ENTERED.  PLEASE  TRY  AGAIN'; 
-GOTO  SECTION2 
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-OFFIT 

OFFLINE 

SET  PANEL=135 

SET  WIDTH=135 

-GOTO  GOODSEL 

-ONIT 

ONLINE 

-GOTO  GOODSEL 
-RPTl 

-TYPE  "PLEASE  WAIT  -  -  PROGRAM 
EX  CLINICl 
-RUN 

-GOTO  SCRIT 
-RPT2 

-TYPE  "PLEASE  WAIT  -  -  PROGRAM 
EX  CLINIC2 
-RUN 

-GOTO  SCRIT 
-RPT3 

-TYPE  "PLEASE  WAIT  -  -  PROGRAM 
EX  CLINIC3 
-RUN 

-GOTO  SCRIT 
-* 

-RPT4 

-TYPE  "PLEASE  WAIT  PROGRAM 

EX  PROVl 
-RUN 

-GOTO  SCRIT 
-RPT5 

-TYPE  "PLEASE  WAIT  PROGRAM 

EX  PROV2 
-RUN 

-GOTO  SCRIT 
-* 

-RPT6 

-TYPE  "PLEASE  WAIT  -  -  PROGRAM 
EX  PROV3 
-RUN 

-GOTO  SCRIT 
-* 

-RPT7 

-TYPE  "PLEASE  WAIT  -  PROGRAM 

EX  PROV4 
-RUN 

-GOTO  SCRIT 


LOADING" 


LOADING" 


LOADING" 


LOADING" 


LOADING" 


LOADING" 


LOADING" 
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PROGRAM  LOADING” 


•RPT8 

-TYPE  "PLEASE  WAIT - 

EX  PROV5 
-RUN 

-GOTO  SCRIT 

•* 

-RPT9 

-TYPE  "PLEASE  WAIT  -  PROGRAM  LOADING" 

EX  CLINIC4 
-RUN 

-GOTO  SCRIT 
-RPTIO 

-TYPE  "PLEASE  WAIT  -  PROGRAM  LOADING" 

EX  MILTl 
-RUN 

-GOTO  SCRIT 
-RPT13 

-TYPE  "PLEASE  WAIT  -  PROGRAM  LOADING" 

EX  MILT2 
-RUN 

-GOTO  SCRIT 
-* 

-RPT12 

-TYPE  "PLEASE  WAIT  -  PROGRAM  LOADING" 

EX  MILT 3 
-RUN 

-GOTO  SCRIT 

.********************  CORRECTION  DATA  BASE  MENU  ********** 

-CORRECT 

-CRTCLEAR 

-SET  &REPLY= '  ' ; 

-SET  &MSG= '  ' ; 

-SET  &CTITLE= ' CORRECTION  MENU ' ; 

-SECTIONS 

-CRTFORM 


AMBULATORY  CARE 

DATA 

MANAGEMENT  SYSTEM 

<.H.A. 

D.&CTITLE  <77 

II” 

PLEASE  SELECT  A 

PROCESS 

A  •  •  « 

Correct 

Clinic  Code 

E  ... 

Future  Application 

B  •  •  • 

Correct 

Provider  Code 

F  .  .  . 

Future  Application 

c  ... 

Correct 

Patient  ID 

G  •  •  • 

Future  Application 

D  .  .  . 

Future  Application 

H  .  .  . 

Future  Application 

X  . . .  RETURN 

TO  PREVIOUS 

MENU 

5 


<.IRHW.&REPLY  <77  \ 


— ^  —  ■ —  —  —  -  -  ■-  - 

ENTER  YOUR  SELECTION 

<.H.Y.D.&MSG  <77  i|  »• 

-  - —  - 

-SET  &DEST=DECODE  &REPLY  (A  CLINIC  B  PROV  C  PATIEN  D  DSEL  E  ESEL  F  FSE 
G  GSEL  H  HSEL  X  SECTIONl  ELSE  NOGO) ; 

-GOTO  &DEST 
-CLINIC 
EX  RXXFCCL 
-RUN 

-GOTO  CORRECT 
-PROV 

EX  RXXFCPR 
-RUN 

-GOTO  CORRECT 
-PATIEN 
EX  RXXFCPA 
-RUN 

-GOTO  CORRECT 
-DSEL 

-GOTO  CORRECT 
-ESEL 

-GOTO  CORRECT 
-FSEL 

-GOTO  CORRECT 
-GSEL 

-GOTO  CORRECT 
-HSEL 

-GOTO  CORRECT 
-NOGO 

-SET  &MSG  =  'INCORRECT  SELECTION  ENTERED.  PLEASE  TRY  AGAIN'; 

-GOTO  SECTION3 

-It*********************  PREPARE  SHIPMENT  TO  DETRICK  MENU  ********** 
-SHIPMENT 

-SET  S.HTITLE= '  PREPARE  SHIPMENT  TO  FT.  DETRICK'; 

-SET  &MSG=  '  ' ; 

-SECTION4 
-CRTCLEAR 
-SET  &REPLY= '  ' ; 

-CRTFORM 


AMBULATORY  CARE  DATA  MANAGEMENT  SYSTEM 


<.H.A.D.&HTITLE  <77  || " 

PLEASE  SELECT  A  PROCESS 


•i 


A  ...  VISIT  File  Preparation 
B  ...  PROVIDER  File  Preparation 
C  ...  PATIENT  File  Preparation 


E 

F 

G 


Future  Application 
Future  Application 
Future  Application 
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! 


—  tt 


!• 


D 


—  H 
.11 

—  il 
_ll 


CLINIC  File  Preparation  H  . . .  Future  Application 

X  -  EXIT  TO  PREVIOUS  MENU 

ENTER  YOUR  SELECTION .  < .  IRHW.  &REPLY  <77  || 

<.H.yELL.D.&MSG  <77  ||" 


-SET  &DEST=DECODE  &REPLY  (A  VIDUMP  B  PRDUMP  C  PADUMP  D  CLDUMP  E  ESELS 
F  FSELS  G  GSELS  H  HSELS  X  SECTIONl  ELSE  NOGOS) ; 

-GOTO  &DEST 
-NOGOS 

-SET  &MSG  =  'INCORRECT  SELECTION  ENTERED.  PLEASE  TRY  AGAIN'; 

-GOTO  SECTION4 
-VIDUMP 
EX  RXXFDVI 
-RUN 

-GOTO  SHIPMENT 
-PRDUMP 
EX  RXXFDPR 
-RUN 

-GOTO  SHIPMENT 
-PADUMP 
EX  RXXFDPA 
-RUN 

-GOTO  SHIPMENT 
-CLDUMP 
EX  RXXFDCL 
-RUN 

-GOTO  SHIPMENT 
-ESELS 

-GOTO  SHIPMENT 
-FSELS 

-GOTO  SHIPMENT 
-GSELS 

-GOTO  SHIPMENT 
-HSELS 

-GOTO  SHIPMENT 

-*************  NIGHT  REPORT  PROCESSING  ************************** 

-TONIGHT 

-SET  &&NITE='Y'; 

DOS  IF  EXIST  C: STKEX.DAT  ERASE  C: STKEX.DAT 

DOS  IF  EXIST  E; NITE.DAT  ERASE  E; NITE.DAT 

DOS  FI  STKEX  DISK  C: STKEX.DAT  (RECFM  FB  LRECL  120 

DOS  FI  STKEX  DISK  C: STKEX. DAT  APPEND 

OFFLINE  CLOSE 

FI  OFFLINE  DISK  E: NITE.DAT 

FI  OFFLINE  DISK  E: NITE.DAT  APPEND 

-RUN 

SET  MORE=OFF 
-SET  &STKCTR  =  ' 0 ' ; 

-SET  &READEX  =  '  ' ; 
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-SET  &MSG  =  '  ' ; 

-SET  &NTITLE=' REPORT  SELECTION  MENU  -  FOR  NIGHT  PROCESSING*; 
-SET  &PRT  =  ' 1 ' ; 

-SET  &REPLY  =  '  ' ; 

-SET  &&RPT  =  '  ' ; 

-***  SET  REPORT  FLAGS  FOR  SELECTION  TRACKING  *** 

-SET  &RF01  =  '  ' ; 

-SET  &RF02  -  •  ' ; 

-SET  &RF03  =  '  '  ; 

-SET  &RF04  =  '  '  ; 

-SET  &RF05  =  '  ' ; 

-SET  &RF06  =  '  ' ; 

-SET  &RF07  =  '  ' ; 

-SET  &RF08  =  '  '  ; 

-SET  &RF09  =  '  ' ; 

-SET  &RF10  =  '  ' ; 

-SET  &RF11  =  '  '  ; 

-SET  &RF12  =  '  '  ; 

-SCRPSW 

-* 

-SECTIONS 

-CRTFORM 


-SET  &DEST=DECODE  &REPLY  (1  RTIME  2  RTIME  3  RTIME  4  RTIME  5  RTIME 
6  RTIME  7  RTIME  8  RTIME  9  RTIME  10  RTIME  11  RTIME  12  RTIME 
X  EXITIT  E  EXECIT  ELSE  NOGON) ; 

-GOTO  &DEST 
-NOGON 

-SET  &MSG  =  'INCORRECT  SELECTION  ENTERED.  PLEASE  TRY  AGAIN'; 
-GOTO  SECTIONS 

-RTIME 

-SET  SiSTKCTR  =  &STKCTR  +  1; 
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-SET  &DEST=DECODE  &REPLY  (1  RPTIN  2  RPT2N  3  RPT3N  4  RPT4N  5  RPT5N  6  RP 
7  RPT7N  8  RPT8N  9  RPT9N  10  RPTION  11  RPTllN  12  RPT12N) ; 

-GOTO  &DEST 

-EXITIT 

OFFLINE  CLOSE 

DOS  FI  OFFLINE  PRINTER 

-SET  &&NITE  =  'N'; 

-RUN 

-GOTO  SCRIT 

—  li'kltltlfklileltlfkltltlfklililfklililtlfklililtltitltltltltltlfkltltltltltlfk'it'klfklfklfkltlclfklclfklcltltltlilcliltlclfk 

-EXECIT 

-CRTFORM 

_ii  11 
_•!  II 
_ll  II 
_ll  H 
_ll  II 
_ll  II 
_ll  II 

-"  ARE  YOU  READY  TO  RUN  NIGHT  TIME  PROCESSING  " 

_ii  II 
_ii  II 

ENTER  Y  (YES)  OR  N  (NO)  OR  A  (ABORT)  :<&SEL" 

-IF  &SEL  EQ  'Y*  GOTO  TESTSTK; 

-IF  &SEL  EQ  'A'  GOTO  ABORTIT; 

-SET  &MSG  =  ' PLEASE  ENTER  ADDITION  REPORTS  NOW  • ; 

-GOTO  SCRIT 

-ABORTIT 

-SET  &MSG  =  'ABORT  THE  RUN  -  TRY  ENTERING  AGAIN  ' ; 

-GOTO  START 
-TESTSTK 

-IF  &STKCTR  GT  'O'  GOTO  RUNITNOW; 

-SET  &MSC  =  ' YOU  HAVE  NOT  YET  SELECTED  ANY  REPORTS  ' ; 

-GOTO  START 

-RUNITNOW 

-* 

-*  EXECUTE  NIGHT  PROCESSING 

-* 

-SET  &&NITE  =  'Z'; 

-DOS  FI  STKEX  DISK  C; STKEX.DAT 
OFFLINE 

SET  PANEL  =  132 
SET  WIDTH  =  132 
-RUN 

EX  STKEX.DAT 
-TYPE 

—TYPE  *************************************************************** 

-TYPE  * 

-TYPE  * 


NIGHT  REPORTS  IN  PROGRESS 


-TYPE  * 

-TYPE  * 

-TYPE  *  !!!  WARNING  !!! 

-TYPE  * 

-TYPE  *  ***DO  NOT  DISTURB  COMPUTER  ** 

-TYPE  * 

-TYPE  * 

-TYPE  *  TOTAL  REPORTS  TO  BE  PROCESSED:  &STKCTR 

-TYPE  * 

—TYPE  *************************************************************** 
-RUN 

-GOTO  EXITIT 
-* 

-hit********  *******  *******  ********  **********************  *************** 

-RPTIN 

-* 

EX  RPTCRT 
-RUN 

-IF  &&RTN  EQ  'X'  GOTO  SECTIONS; 

-* 

-WRITE  STKEX  EX  CLINICl  CLN=&&CLN,  ST=&&ST,  END=&StEND,  PROV=&SiPROV 
-SET  &MSG  =  'REPORT  1  HAS  BEEN  STACKED  FOR  NIGHT  TIME  PROCESSING'; 
-SET  &RF01  = 

-GOTO  SECTIONS 

-********************************************************************* 

-RPT2N 

-* 

EX  RPTCRT 
-RUN 

-IF  &&RTN  EQ  'X'  GOTO  SECTIONS; 

-* 

-WRITE  STKEX  EX  CLINIC2  CLN=&&CLN,  ST=&&ST,  END=&&END,  PROV=&&PROV 
-SET  &MSG  =  'REPORT  2  HAS  BEEN  STACKED  FOR  NIGHT  TIME  PROCESSING'; 
-SET  &RF02  =  ' * ' ; 

-GOTO  SECTIONS 

-********************************************************************* 

-RPT3N 

-* 

EX  RPTCRT 
-RUN 

-IF  &&RTN  EQ  'X'  GOTO  SECTIONS; 

-* 

-WRITE  STKEX  EX  CLINIC3  CLN=&&CLN,  ST=&&ST,  END=&&END,  PROV=i&PROV 
-SET  &MSG  =  'REPORT  3  HAS  BEEN  STACKED  FOR  NIGHT  TIME  PROCESSING'; 
-SET  &RF03  =  ' * ' ; 

-GOTO  SECTIONS 

-********************************************************************* 

-RPT4N 

-* 

EX  RPTCRT 
-RUN 

-IF  &&RTN  EQ  'X'  GOTO  SECTIONS; 
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-* 

-WRITE  STKEX  EX  PROVl  CLN=&&CIiN,  ST=iStST,  END=&&END,  PROV=&&PROV 
'  -SET  fitMSG  =  'REPORT  4  HAS  BEEN  STACKED  FOR  NIGHT  TIME  PROCESSING'; 

-SET  &RF04  =  ' * ' ; 

-GOTO  SECTIONS 

-***4***************************************************************** 

-RPT5N 

-* 

EX  RPTCRT 
-RUN 

-IF  &&RTN  EQ  'X'  GOTO  SECTIONS; 

-WRITE  STKEX  EX  PROV2  CUf-Sc&CLN,  ST=i&ST,  END=&&END,  PROV-&&PROV 
-SET  &MSG  =  'REPORT  S  HAS  BEEN  STACKED  FOR  NIGHT  TIME  PROCESSING'; 
-SET  &RFOS  =  '*•; 

-GOTO  SECTIONS 

^i,************************** *****************************  ************* 
-* 

-RPT6N 

-* 

EX  RPTCRT 
-RUN 

-IF  &&RTN  EQ  'X'  GOTO  SECTIONS; 

—  * 

-WRITE  STKEX  EX  PROV3  CLN=&&CLN,  ST=&&ST,  END=&&END,  PROV=&&PROV 
-SET  &MSG  =  'REPORT  6  HAS  BEEN  STACKED  FOR  NIGHT  TIME  PROCESSING'; 
-SET  &RF06  =  ' * ' ; 

1  •  -GOTO  SECTIONS 

~********************************************************************* 

-RPT7N 

EX  RPTCRT 1 
-RUN 

-IF  &&RTN  EQ  'X'  GOTO  SECTIONS; 

-* 

-WRITE  STKEX  EX  PROV4  ST=&&ST,  END=&&END,  PROV=&&PROV 

-SET  &MSG  =  'REPORT  7  HAS  BEEN  STACKED  FOR  NIGHT  TIME  PROCESSING'; 

-SET  &RF07  =  ' * ' ; 

-GOTO  SECTIONS 

-********************************************************************* 

-RPT8N 

-* 

EX  RPTCRT 1 
-RUN 

-IF  &&RTN  EQ  'X'  GOTO  SECTIONS; 

— * 

-WRITE  STKEX  EX  PROV5  ST=&&ST,  END=&&END,  PROV=&&PROV 

-SET  &MSG  =  'REPORT  8  HAS  BEEN  STACKED  FOR  NIGHT  TIME  PROCESSING'; 

-SET  &RF08  =  ' * ' ; 

-GOTO  SECTIONS 

-********************************************************************* 

-RPT9N 
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-* 

EX  RPTCRT 
-RUN 

-IF  &&RTN  EQ  'X'  GOTO  SECTIONS; 

-* 

-WRITE  STKEX  EX  CLINIC4  CLN=Si&CLN,  ST=&&ST,  END=&&END,  PROV=&&PROV 
-SET  &MSG  =  'REPORT  9  HAS  BEEN  STACKED  FOR  NIGHT  TIME  PROCESSING'; 

-SET  &RF09  =  ' * ' ; 

-GOTO  SECTIONS 

—  It  IHth*  11**11*  It  It*  It****  It  It  hit  *  11*1111*  It  hit  ** -kit -kit  It  It  It  hit  it  It  It  hit  hit  It  ifk*  It  ***  It  It  *  hit  h*  hit  Itlfk 

-RPTION 

-* 

EX  RPTCRT2 
-RUN 

-IF  fii&RTN  EQ  'X'  GOTO  SECTIONS; 

-* 

-WRITE  STKEX  EX  MILTl  CAT=&&CAT,  ST=S.&ST,  END=&&END 

-SET  &MSG  =  'REPORT  10  HAS  BEEN  STACKED  FOR  NIGHT  TIME  PROCESSING'; 

-SET  SiRFlO  =  '  *  '  ; 

-GOTO  SECTIONS 

-********************************************************************* 

-RPTllN 

EX  RPTCRT3 
-RUN 

-IF  &5(RTN  EQ  'X'  GOTO  SECTIONS; 

-SET  4COM  =  ' , ' ;  • 

-* 

-WRITE  STKEX  EX  MILT2  FT=&&FT&COM 

-WRITE  STKEX  L0C1=4&L0C1,  LOC2=&&LOC2,  LOC3=&&LOC3,  LOC4=&&LOC4&COM 
-WRITE  STKEX  ST=&&ST,  END=&&END,  &&CAT 

-SET  &MSG  =  'REPORT  11  HAS  BEEN  STACKED  FOR  NIGHT  TIME  PROCESSING'; 

-SET  4RF11  =  ' * ' ; 

-GOTO  SECTIONS 

^********************************************************************* 

-RPT12N 

EX  RPTCRT4 
-RUN 

-IF  &&RTN  EQ  'X'  GOTO  SECTIONS; 

-SET  &COM  =  ' , ' ; 

-* 

-WRITE  STKEX  EX  MILT3  CLN=&&CLN,  ST=&&ST,  END=fi.&END&COM 
-WRITE  STKEX  RP=&&RP 

-SET  &MSG  =  'REPORT  12  HAS  BEEN  STACKED  FOR  NIGHT  TIME  PROCESSING'; 

-SET  &RF12  =  ' * ' ; 

-GOTO  SECTIONS 
-EXIT 
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-A********************************************* ************* 
-*  * 

-*  PROGRAM:  MILTl.FEX  MODIFIED:  1/14/86  DRB  * 

— *  * 

-*  REPORT:  10  MENU  PROGRAM:  RPTCRT2 . FEX  * 

-*  * 

^h********************************************************** 


-SET  &&RPT  =  'MILITARY  UNIT  REPORT' ; 

EX  RPTCRT2 
-RUN 

-IF  &&RTN  EQ  'X'  GOTO  RTN  ELSE  GOTO  CONT; 

-RTN 

-EXIT 

-CONT 

-IF  &&NITE  EQ  'Z'  THEN  GOTO  ASET  ELSE  GOTO  CONTI; 

-ASET 

-SET  &&ST=&ST; 

-SET  &SiEND=&END; 

-SET  Ji&CAT=&CAT; 

-SET  &&FT=&FT; 

-CONTI 

JOIN  DIAG1_C0DE  IN  VISIT  TO  DGNCD  IN  DIAGNOS  AS  DJOIN 
JOIN  PATIENT_ID  IN  VISIT  TO  PATIENT_ID  IN  PATIENT  AS  JJOIN 
DEFINE  FILE  VISIT 

MALE/I4=IF  SEX  EQ  'M'  THEN  1  ELSE  0; 

FEMALE/14  ==  IF  SEX  EQ  'F'  THEN  1  ELSE  0; 

QUARTERS/ I 4 =IF  SUPPL_DISP  EQ  'J'  THEN  1  ELSE  0; 
PROFILES/I4=IF  SUPPL_DISP  EQ  'M'  THEN  1  ELSE  0; 

YES/I4=  IF  JOB_RELATED  EQ  'Y'  THEN  1  ELSE  0; 

NO/I4=  IF  JOB_RELATED  EQ  'N'  THEN  1  ELSE  0; 

END 

TABLE  FILE  VISIT. SUPPL_DISP 
HEADING  CENTER 

"  MILITARY  UNIT  REPORT  FOR  FORT  &&FT" 

"FROM  &&ST  TO  &&END  </2" 

COUNT  LITHO_CODE  NOPRINT 
SUM. FEMALE  IN  50 
SUM. MALE  IN  60 

SUM. QUARTERS  IN  70  SUM. PROFILES  IN  80 
SUM. YES  AS  '  JOB, RELATED,  YES'  IN  90 
SUM. NO  AS  '  JOB, RELATED,  NO'  IN  100 

BY  HIGHEST  PT_LOC  AS  'UIC  '  IN  30 
BY  SUPPL_DISP  NOPRINT 
IF  PT_CATEGORY  EQ  &&CAT 
IF  VISIT_DATE  FROM  &&ST  TO  4&END 
IF  SUPPL_DISP  EQ  'M'  OR  'J' 

END 

JOIN  CLEAR  * 

-RUN 
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* 

-* 

-* 

PROGRAM;  MILT2.FEX 

MODIFIED:  1/14/86 

DRB 

* 

* 

-* 

REPORT:  11 

MENU  PROGRAM:  RPTCRT3. 

FEX 

* 

* 

-It******************************************************** 

-* 

-SET  &&RPT  =  'UNIT  HEALTH  REPORT'; 

EX  RPTCRT3 
-RUN 

-IF  &&RTN  EQ  'X'  GOTO  RTN  ELSE  GOTO  CONT; 

-RTN 

-EXIT 

-CONT 

-IF  &&NITE  EQ  'Z'  THEN  GOTO  ASET  ELSE  GOTO  CONTI; 

-ASET 

-SET  &&ST=&ST; 

-SET  &&END=&END; 

-SET  &&LOCl=fiiLOCl; 

-SET  &&LOC2=4LOC2; 

-SET  &&LOC3=&LOC3 ; 

-SET  &&LOC4=&LOC4 ; 

-SET  &&CAT=&CAT; 

-SET  &&FT=&FT; 

-CONTI 

JOIN  DIAGl_CODE  IN  VISIT  TO  DGNCD  IN  DIAGNOS  AS  DJOIN 
JOIN  PATIENT_ID  IN  VISIT  TO  PATIENT_ID  IN  PATIENT  AS  JJOIN 
DEFINE  FILE  VISIT 

DES/A50=IF  DIAG_DESCR  EQ  '  •  THEN  'NO  DESCRIPTION  O 
ELSE  DIAG_DESCR; 

MALE/I4=IF  SEX  EQ  'M'  THEN  1  ELSE  0; 

FEMALE/I4=IF  SEX  EQ  'F'  THEN  1  ELSE  0; 

END 

TABLE  FILE  VISIT 

"<25  UNIT  HEALTH  REPORT  FOR  &&FT" 

"<30  FROM  &&ST  TO  &&END  </2" 

COUNT  LITHO_CODE  NOPRINT 

SUM. FEMALE  IN  72  SUM. MALE  IN  82  ROW-TOTAL  COLUMN-TOTAL 

BY  DES  AS  '  DIAGNOSIS  DESCRIPTION  '  IN  1 

IF  PT_CATEGORY  EQ  &&CAT 

IF  VISIT_DATE  FROM  SfiiST  TO  &&END 

IF  PTLOC  EQ  &&LOC1  OR  &&LOC2  OR  &&LOC3  OR  &&LOC4 
END 

JOIN  CLEAR  * 

-RUN 
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-*  * 

-*  PROGRAM:  MILT3.FEX  MODIFIED:  1/14/86  DRB  * 

-*  * 

-*  REPORT:  12  MENU  PROGRAM:  RPTCRT4.FEX  * 

-*  * 

-* 


EX  RPTCRT4 
-RUN 

-IF  &&RTN  EQ  'X'  GOTO  RTN  ELSE  GOTO  CONT? 

-RTN 

-EXIT 

-CONT 

-IF  &&NITE  EQ  ‘Z'  THEN  GOTO  ASET  ELSE  GOTO  CONTI; 

-ASET 

-SET  &&ST=&ST; 

-SET  &&END=ScEND; 

-SET  &&RP=&RP; 

-SET  &&CLN=&CLN; 

-CONTI 

JOIN  DIAGl_CODE  IN  VISIT  TO  DGNCD  IN  DIAGNOS  AS  DJOIN 
JOIN  PATIENT_ID  IN  VISIT  TO  PATIENT_ID  IN  PATIENT  AS  JJOIN 
DEFINE  FILE  VISIT 
DOB/I6=yMD(PT_DOB,&yMD) ; 

AGE/I2=DOB/365; 

Z_l/I4  =  IF  AGE  LT  0  THEN  1  ELSE  0; 

ONE_4/I4  =  IF  AGE  GE  1  AND  AGE  LE  4  THEN  1  ELSE  0; 

FIVE_14/I4  =  IF  AGE  GE  5  AND  AGE  LE  14  THEN  1  ELSE  0; 

FIF_19/I4  =  IF  AGE  GE  15  AND  AGE  LE  19  THEN  1  ELSE  0; 

TW_39/I4  =  IF  AGE  GE  20  AND  AGE  LE  39  THEN  1  ELSE  0; 

FORT_64/I4  =  IF  AGE  GE  40  AND  AGE  LE  64  THEN  1  ELSE  0; 

SIX_GT/I4  =  IF  AGE  GE  65  THEN  1  ELSE  0; 

WD/A50=IF  DIAG_DESCR  EQ  '  '  THEN  'NO  DESCRIPTION 
ELSE  DIAG_DESCR; 

END 

TABLE  FILE  VISIT. PLACE 
HEADING  CENTER 
"&&RP" 

"FOR  &&ST  TO  &&END  </2" 

"<40  AGE  GROUP  </l" 

IF  VISIT_DATE  FROM  &&ST  TO  &&END 
IF  PLACE  EQ  '3' 

IF  PROC_CODE  EQ  '90720' 

IF  CLINIC  EQ  &&CLN 
IF  PT_DOB  NE  0 

SUM  CNT.INP  REFERAL  NOPRINT 


Z  1 

AS 

'  0, TO, 12, MO' 

IN 

54 

ONE  4 

AS 

'  l,TO,  4,YR' 

IN 

60 

FIVE  14 

AS 

'  5,TO,14,YR' 

IN 

66 

FIF  19 

AS 

'15, TO, 19, YR' 

IN 

72 

TW  39 

AS 

'20, TO, 39, YR' 

IN 

78 

0 


1 


FORT_64  AS  ' 40,TO, 64 , YR'  IN  84 

SIX_GT  AS  '65,  &,UP'  IN  90  ROW-TOTAL  AND  COLUMN-TOTAL 

BY  WD  AS  *  DIAGNOSIS  DESCRIPTION  '  IN 

ON  WD  SKIP-LINE 
FOOTING 

"  <54  REFERRALS  IN  <70  <CNT .  INP_REFERAL’' 

"  <54  TELEPHONE  VISIT  <70  <CNT. PLACE" 

"  <54  IMMUNIZATIONS  <70  <CNT. PROC_CODE" 

END 

-RUN 

JOIN  PROC_CODE  IN  VISIT  TO  PROC_CODE  IN  PROCEDUR  JJOIN4 
DEFINE  FILE  VISIT 
DOB/I6=YMD(PT_DOB,&YMD) ; 

AGE/I2=DOB/365; 

Z_l/I4  =  IF  AGE  LT  0  THEN  1  ELSE  0; 

ONE_4/I4  =  IF  AGE  GE  1  AND  AGE  LE  4  THEN  1  ELSE  0; 

FIVE_14/I4  =  IF  AGE  GE  5  AND  AGE  LE  14  THEN  1  ELSE  0; 

FIF_19/I4  =  IF  AGE  GE  15  AND  AGE  LE  19  THEN  1  ELSE  0; 

TW_39/I4  =  IF  AGE  GE  20  AND  AGE  LE  39  THEN  1  ELSE  0; 

FORT_64/I4  =  IF  AGE  GE  40  AND  AGE  LE  64  THEN  1  ELSE  0; 

SIX_GT/I4  =  IF  AGE  GE  65  THEN  1  ELSE  0; 

WD/A67=IF  PROC_DESCR  EQ  '  '  THEN  'NO  DESCRIPTION  ON 
ELSE  PROC_DESCR; 

END 

-RUN 

TABLE  FILE  VISIT. PLACE 
HEADING  CENTER 
"&5.RP" 

"FOR  S&ST  TO  4&END  </2" 

"<40  AGE  GROUP  </l" 

IF  VISIT_DATE  FROM  &&ST  TO  &&END 
IF  PLACE  EQ  '3' 

IF  PROC_CODE  EQ  '90720' 

IF  CLINIC  EQ  &&CLN 

IF  PT_DOB  NE  0 

SUM  CNT.INP  REFERAL  NOPRINT 


Z  1 

AS 

'  0, TO, 12, MO' 

IN 

54 

ONE  4 

AS 

'  l,TO,  4,YR' 

IN 

60 

FIVE  14 

AS 

'  5,TO,14,YR' 

IN 

66 

FIF  19 

AS 

'15, TO, 19, YR' 

IN 

72 

TW  39 

AS 

'20, TO, 39, YR' 

IN 

78 

FORT  64 

AS 

'40, TO, 64, YR' 

IN 

84 

SIX  GT 

AS 

'65,  &,UP' 

IN 

90  ROW-TOTAL  AND  COLUMN-TOTAL 

WD 

AS 

1 

PROCEDURE  DESCRIPTION 

ON  WD  SKIP-LINE 
FOOTING 

"  <54  REFERRALS  IN  <70  <CNT . INP_REFERAL" 
"  <54  TELEPHONE  VISIT  <70  <CNT. PLACE" 

"  <54  IMMUNIZATIONS  <70  <CNT. PROCCODE" 

END 

-RUN 

JOIN  CLEAR  * 


2 


OTHER. MAS 


FIIiENAME=PROCEDUR,  SUFFIX=FOC 
SEGNAME=OTHERCOD, SEGTYPE=S1 

FIELDNAME=OTHER_CODE,  ALIAS=OTHC,  FORMAT=A5, 

FIELDNAME=OTHER_DESCR,  ALIAS=OTHDSC ,  FORMAT=A67 

END 

DBA=LUGNUT,$ 

USER=NUTMEG,  ACCESS=RW,  $ 


FIELDTYPE=I , $ 
,$ 


PATIENT. MAS 


FILE=PATIENT, SUFFIX=FOC 
SEGNAME=PTSEG , SEGTYPE=S 1 

FIELD=PATIENT_ID, PTID, All , FIELDTYPE=I , $ 
FIELD=PT_DOB, PTDOB, I6YMD, $ 
FIELD=PT_CATEGORY , CATEG , A3 , $ 
FIELD=PT_LITHO, PTLITHO, A8 , $ 
FIELD=PT_REGDATE , REGDATE , I6YMD, $ 
FIELD=PT_GENDER , SEX , A1 , $ 

FIELD=PT_RACE , RACE , A1 , $ 

FIELD=PT_PREFIX, PREFIX, A2 , $ 
FIELD=PT_PAY_GRADE , PAYGRADE , A2 , $ 
FIELD=PT_JOB_CODE , JOBCODE , A4 , $ 
FIELD=PT_LOCATION , PTLOC , A6 , $ 
FIELD=PT_TRN_TDY , TRAINEE , A1 , $ 
FIELD=PT_VAELIG , VA , A1 , $ 

FIELD=PT_HCI , HCI , A1 , $ 

FIELD=PT_ZIP  CODE, ZIP, A5,$ 
FIELD=PT_DUAL_SSN , PTDUALSSN , A9 , $ 
FIELD=PT_FOREIGN , PTFORGN , A3 , $ 

END 

DBA=LUGNUT,$ 

USER=NUTMEG,  ACCESS=RW,  $ 


1 


PROCDMP.FEX 


-CRTCLEAR 
“TYPE 
“TYPE 
“TYPE 
“TYPE 
“TYPE 
“TYPE 
“TYPE 
“TYPE 
“READ  SYS IN 
“CRTCLEAR 
“TYPE 

“TYPE  PREPARATION  OF  FT.  DETRICK  BERNOULLI  PROCEDURE  FILE 
“TYPE 

“TYPE  IN  PROGRESS 

“TYPE 

USE  C: SITE. IDF 
END 

FILEDEF  SITEF  DISK  C: SITE. IDF 
“RUN 

“SET  &&SITE=' 

-READ  SITEF  &&SITE 
USE 

D:PROCEDUR.FOC 
E;DETPROC.FTM  NEW 

END 

FILEDEF  DETR  DISK  E ; DETPROC . FTM 
“SET  ALL=ON; 

DEFINE  FILE  PROCEDUR 
SITE/A4='&&SITE' ; 

END 

-RUN 

“TYPE  PROCEDURE  RECORDS  BEING  PROCESSED 

TABLEF  FILE  PROCEDUR 

PRINT  SITE  SEG.PRCCD 

ON  TABLE  SAVE  AS  DETR 

END 

-RUN 


PROCEDUR. FOC  DUMP  PROGRAM 

PREPARE  BERNOULLI  CARTRIDGE  FOR  SHIPMENT  TO  FT.  DETRICK 

1.  PLACE  NEWLY  FORMATED  CARTRIDGE  IN  DRIVE  E. 

2.  DRIVE  D  SHOULD  CONTAIN  PROCEDUR. FOC  FILE  (STANDARD) 

HIT  ENTER  TO  CONTINUE 
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PROCEDUR.MAS 


FILENAME=PROCEDUR, SUFFIX=FOC 
SEGNAME=PROCEDUR, SEGTYPE=S1 

FIELDNAME=PROC_CODE,  ALIAS=PRCCD,  FORMAT=-A5,  FIELDTYPE=I ,  $ 

FIELDNAME=PROC_DESCR,  ALIAS=PRCDSC,  FORMAT=A67  ,$ 

END 

DBA=LUGNUT,$ 

USER=NUTMEG,  ACCESS=RW,  $ 


PROFILE. FEX 


SET  MSG=OFF 
SET  PAUSE=OFF 
SET  WIDTH=132 
SET  LINES=66 
SET  PANEL=132 
SET  COLOR=ON 
OFFLINE 
-EXIT 


•# 


— hiflt  It  It  hit  It  h  It  It  It -kit  It  It  It  it  *  It  lilt  It  It -kit  hit  It  it  hit  It  ******  ii  It  tltic  it************ 


-* 

PROGRAM;  PROVl.FEX 

MODIFIED;  S/ll/Bl  DRB 

* 

* 

FOR  NEW  DESIGN 

* 

REPORT;  4 

MENU  PROGRAM;  RPTCRT. FEX 

* 

* 

•-********************************************************* 

-SKT  &&RPT  =  'PROVIDER  DIAGNOSIS  REPORT'; 

EX  RPTCRT 
-RUN 

-IF  fitfiiRTN  EQ  'X'  GOTO  RTN  ELSE  GOTO  CONT; 

-RTN 

-EXIT 

-CONT 

-IF  &&NITE  EQ  'Z'  THEN  GOTO  ASET  ELSE  GOTO  CONTI; 

-ASET 

-SET  &&ST=&ST; 

-SET  &&END=&END; 

-SET  &&CLN=&CLN; 

-SET  &&PROV=&PROV; 

-CONTI 

JOIN  DIAGl_CODE  IN  VISIT  TO  DIAG_CODE  IN  DIAGNOS  AS  DJOIN 
JOIN  CLINIC  IN  VISIT  TO  CLINIC  IN  CLINIC  AS  JJOIN 
JOIN  PROV_ID  IN  VISIT  TO  PROV_ID  IN  PROVIDER  AS  JJOINl 
DEFINE  FILE  VISIT 

FINT/A2=EDIT(PROV_FST  NME, '9') | ) ' . ' ; 

NM/A20*  (PR0V_LST_NMET ] ' ,  ' | | FINT) ; 

END 

-**************************************************** 

-*  GENERATE  REPORT  FOR  PRIMARY  PROVIDERS 
—**************************************************** 

-* 

TABLE  FILE  VISIT 
COUNT  LirHO_CODE 
BY  CLINIC  BY  CL_TITLE 
BY  NM 

BY  PROV_ID  AS  PID 
COUNT  LITHO_CODE 
SUM. DIAG_DESCR 
COMPUTE  PA=100  *  C2/C1; 

BY  CLINIC  BY  CL_TITLE 
BY  NM 

BY  PROV_ID 
BY  DIAGl_CODE 
IF  CLINIC  EQ  S&CLN 
IF  PROV_ID  EQ  &&PROV 
IF  VISIT_DATE  FROM  &&ST  TO  &&END 
ON  TABLE  HOLD  AS  HOLDl 
END 
-RUN 

TABLE  FILE  HOLDl 


1 


HEADING  CENTER 

"UCA  :  <CLINIC  <CL_TITLE'' 

“FIRST  PROVIDER  PRIMARY  DIAGNOSIS  REPORT" 
"FROM  &&ST  TO  SStEND" 

n  •• 

"PROVIDER  :  <NM  ID;  <PROV_ID" 

•I  H 
H  H 

BY  CLINIC  NOPRINT 

BY  CL_TITLE  AS  '  CLINIC  NAME  ' 

BY  NM  NOPRINT 

BY  PROV_ID  AS  'PROV,  ID' 

BY  HIGHEST  E09  NOPRINT 

PRINT  DIAG_DESCR  AS  'DESCRIPTION' 

E07  AS  'DIAGNOSIS, COUNT' 

PA  AS  'PERCENT'  COLUMN-TOTAL 

ON  PROV_ID  SUBTOTAL  AS  'TOTAL  FOR' 

ON  PROV_ID  PAGE-BREAK 
FOOTING 

H  11 


J 


"NOTE:  THERE  IS  NO  WAY  TO  DETERMINE  WHETHER  A  DIAGNOSIS  WAS  DONE  BY  T 

NUMBER" 

"  ONE  PROVIDER  OR  THE  NUMBER  TWO  PROVIDER  FOR  ANY  ONE  ENCOUNTER. 
THEREFORE," 

"  THE  ABOVE  DATA  MAY  REFLECT  DIAGNOSES  SPECIFIED  BY  EITHER  PROVIDER 

END 

-RUN 

JOIN  CLEAR  JJOINl 

JOIN  PROV2  IN  VISIT  TO  PROV_ID  IN  PROVIDER  AS  JJOINl 

-It*************************************************** 

-*  GENERATE  REPORT  FOR  SECONDARY  PROVIDERS 
-***********************************11**************** 

DEFINE  FILE  VISIT 
PROV_ID/A5=PROV2 ; 

FINT/A2*EDIT(PROV_FST  NME, '9 ' ) ( | ; 

NM/A20=  (PR0V_LST_NME7| ' ,  ' | | FINT) ; 

END 

-* 

TABLE  FILE  VISIT 
COUNT  LITHO_CODE 
BY  CLINIC  BY  CL_TITLE 
BY  NM 

BY  PROV_ID  AS  PID 
COUNT  LITHO_CODE 
SUM. DIAG_DESCR 
COMPUTE  PA=100  *  C2/C1; 

BY  CLINIC  BY  CL_TITLE 
BY  NM 
BY  PROV_ID 
BY  DIAGl_CODE 
IF  PROV  ID  NE  •  ’ 


4 


2 


L 


IF  CLINIC  EQ  S&CLN 
IF  PROV_ID  EQ  S&PROV 
IF  VISIT_DATE  FROM  &&ST  TO  &&END 
ON  TABLE  HOLD  AS  HOLDl 
END 
-RUN 

TABLE  FILE  HOLDl 

HEADING  CENTER 

"UCA  :  <CLINIC  <CL_TITLE" 

"SECONDARY  PROVIDER  PRIMARY  DIAGNOSIS  REPORT" 
"FROM  S&ST  TO  &&END" 
n  •• 

"PROVIDER  :  <NM  ID:  <PROV_ID" 

••  n 


BY  CLINIC  NOPRINT 

BY  CL_TITLE  AS  '  CLINIC  NAME  • 

BY  NM  NOPRINT 

BY  PROV_ID  AS  'PROV,  ID* 

BY  HIGHEST  E09  NOPRINT 

PRINT  DIAG_DESCR  AS  'DESCRIPTION* 

E07  AS  'DIAGNOSIS, COUNT' 

PA  AS  'PERCENT'  COLUMN-TOTAL 

ON  PROV_ID  SUBTOTAL  AS  'TOTAL  FOR' 

ON  PROV_ID  PAGE-BREAK 
FOOTING 

•I  n 


"NOTE:  THERE  IS  NO  WAY  TO  DETERMINE  WHETHER  A  DIAGNOSIS  WAS  DONE  BY  T 
NUMBER" 

"  ONE  PROVIDER  OR  THE  NUMBER  TWO  PROVIDER  FOR  ANY  ONE  ENCOUNTER. 
THEREFORE," 

"  THE  ABOVE  DATA  MAY  REFLECT  DIAGNOSES  SPECIFIED  BY  EITHER  PROVIDER 
END 

JOIN  CLEAR  * 

-RUN 


-************************************************************ 

-*  * 

-*  PROGRAM:  PROV2.FEX  MODIFIED:  6/17/87  DRB  * 

-*  FOR  NEW  DESIGN  * 

-*  REPORT:  5  MENU  PROGRAM:  RPTCRT.FEX  * 

-*  * 

-it*********************************************************** 

-* 

-SET  &&RPT  =  'PROVIDER  PROCEDURE  REPORT'; 

EX  RPTCRT 
-RUN 

-IF  &&RTN  EQ  'X'  GOTO  RTN  ELSE  GOTO  CONT; 

-RTN 

-EXIT 

-CONT 

-IF  &&NITE  EQ  'Z'  THEN  GOTO  ASET  ELSE  GOTO  CONTI; 

-ASET 

-SET  &&ST=&ST; 

-SET  &&END=&END; 

-SET  &&CLN=&CLN; 

-SET  &&PROV=&PROV; 

-CONTI 

-* 

JOIN  CLINIC  IN  VISIT  TO  CLINIC  IN  CLINIC  AS  CJOIN 

JOIN  PROV_ID  IN  VISIT  TO  PROV_ID  IN  PROVIDER  AS  PVJOIN 

JOIN  PROC_CODE  IN  VISIT  TO  PROC_CODE  IN  PROCEDUR  AS  PCJOIN 

-****************************************************** 

-*  PRIMARY  PROVIDER  REPORT 

-****************************************************** 

DEFINE  FILE  VISIT 

FINT/A2=EDIT(PROV_FST  NME, '9 ' ) | j ; 

NM/ A2  0= ( PROV_LST_NME | J ' ,  ' |  | FINT) ; 

WPROC/A67=IF  PRCDSC  EQ  '  '  THEN  'NO  DESCRIPTION  GIVEN'  ELSE  PRCDSC; 
WNO/I4=l; 

END 

-* 

TABLE  FILE  VISIT 
COUNT  WNO 

BY  CLINIC  BY  CL_TITLE 
BY  NM 

BY  PROV_ID  AS  PID 
COUNT  LITHO_CODE 
COMPUTE  PA=100  *  C2/C1; 

BY  CLINIC  BY  CL_TITLE 
BY  NM 
BY  PROV_ID 
BY  PROC_CODE 
BY  WPROC 

IF  PROV_ID  EQ  &&PROV 
IF  PRCODE  EQ  '!' 

IF  CLINIC  EQ  &&CLN 

IF  VISIT  DATE  FROM  &&ST  TO  &&END 


1 


J 


J 


I 


1 


ON  TABLE  HOLD 

END 

-RUN 

TABLE  FILE  HOLD 
HEADING 

”<47  UCA  :  <CLINIC  <CL_TITLE” 

”<47  PRIMARY  PROVIDER  PROCEDURE  REPORT” 

”<53  FROM  &&ST  TO  &&END” 

II  II 

”<47  PROVIDER;  <NM  ID;  <PROV_ID” 

II  II 
II  II 

PRINT  CL_TITLE  AS  '  CLINIC  NAME  ' 

PROC_CODE  AS  'PROCEDURE,  CODE* 

WPROC  AS  '  PROCEDURE  DESCRIPTION 

LITHO_CODE  AS  'PROCEDURE,  COUNT' 

PA  AS  'PERCENT' 

BY  CLINIC  NOPRINT 
BY  CL_TITLE  NOPRINT 
BY  NM  NOPRINT 
BY  PROV_ID  NOPRINT 
BY  HIGHEST  PA  NOPRINT 
BY  LITHO_CODE  NOPRINT 
ON  PROV_ID  SUBTOTAL  AS  'TOTAL  FOR' 

ON  PROV_ID  PAGE-BREAK 

END 

-RUN 

—  li'klilelfkltifkltlfhlt'kltlfklfkitifklt'k'klililfkltifkitlfk'klUtlilfkltltltltltlelfkli'kitltlt 

-*  SECONDARY  PROVIDER  REPORT 

— -kit*  ****  It*  It  *  It  *****  *****  ****  hit  *111111**  ******* 

JOIN  CLEAR  PVJOIN 

JOIN  PROVIDER_2  IN  VISIT  TO  PROV_ID  IN  PROVIDER  AS  PVJOIN 
-RUN 

DEFINE  FILE  VISIT 
PROV_ID/A5=PROV2 ; 

FINT/A2=EDIT(PROV_FST  NME, ' 9 ' ) | | ; 

NM/ A2  0= ( PROV_LST_NME | J ' ,  ' |  | FINT ) ; 

WPROC/A67=IF  PRCDSC  EQ  '  '  THEN  'NO  DESCRIPTION  GIVEN'  ELSE  PRCDSC 
WNO/I4=l; 

END 

TABLE  FILE  VISIT 
COUNT  WNO 

BY  CLINIC  BY  CL_TITLE 
BY  NM 
BY  PROV_ID 
COUNT  LITHO_CODE 
COMPUTE  PA=100  *  C2/C1; 

BY  CLINIC  BY  CL_TITLE 
BY  NM 


2 


BY  PROV_ID 
BY  PROC_CODE 
BY  WPROC 

IF  PROV_ID  NE  •  • 

IF  PROV_ID  EQ  fiSePROV 
IF  PRCODE  EQ  '2' 

IF  CLINIC  EQ  &&CLN 

IF  VISIT_DATE  FROM  &4ST  TO  &&END 

ON  TABLE  HOLD 

END 

-RUN 

-**** 

TABLE  FILE  HOLD 
HEADING 

'•<47  UCA  ;  <CLINIC  <CL_TITLE'' 

"<47  SECONDARY  PROVIDER  PROCEDURE  REPORT" 

"<53  FROM  S&ST  TO  fii&END" 

II  If 

"<47  PROVIDER:  <NM  ID:  <PROV_ID" 

II  H 
II  II 

PRINT  CL_TITLE  AS  '  CLINIC  NAME  ' 

PROC_CODE  AS  'PROCEDURE,  CODE' 

WPROC  AS  •  PROCEDURE  DESCRIPTION 

LITHO_CODE  AS  'PROCEDURE,  COUNT' 

PA  AS  'PERCENT' 

BY  CLINIC  NOPRINT 
BY  CL_TITLE  NOPRINT 
BY  NM  NOPRINT 
BY  PROV_ID  NOPRINT 
BY  HIGHEST  PA  NOPRINT 
BY  LITHO_CODE  NOPRINT 
ON  PROV_ID  SUBTOTAL  AS  'TOTAL  FOR' 

ON  PROV_ID  PAGE-BREAK 
END 

JOIN  CLEAR  * 

-RUN 


3 


-.it********************************************************* 


* 

-*  PROGRAM:  PROV3.FEX  MODIFIED:  1/14/86  DRB  * 

* 

-*  REPORT:  6  MENU  PROGRAM:  RPTCRT.FEX  * 

-*  * 


^****************************■>1******************  *********** 

-SET  &&RPT  =  'PROVIDER  REPORT  FOR  TIME  AND  APPOINTMENT  STATUS': 

EX  RPTCRT 
-RUN 

-IF  &&RTN  EQ  'X'  GOTO  RTN  ELSE  GOTO  CONT; 

-RTN 

-EXIT 

-CONT 

-IF  St&NITE  EQ  'Z'  THEN  GOTO  ASET  ELSE  GOTO  CONTI; 

-ASET 

-SET  &4ST=&ST; 

-SET  &&END=&END; 

-SET  &&CLN=&CLN; 

-SET  &&PROV=&PROV; 

-CONTI 

JOIN  CLINIC  IN  VISIT  TO  CLINIC  IN  CLINIC  AS  JJOIN 
JOIN  PROV_ID  IN  VISIT  TO  PROV_ID  IN  PROVIDER  AS  JJOIN2 
-INCLUDE  DCODEl 
-RUN 

TABLE  FILE  VISIT 
(•  HEADING  CENTER 

"PROVIDER  REPORT" 

"FOR  TIME  AND  APPOINTMENT  STATUS" 

"FOR  <CL_TITLE" 

"FOR  PROVIDER  <PROV_ID  <100  ***  <PROV_LST_NME  ***" 

"FROM  &&ST  TO  i&END  </2" 

COUNT  LITHO_CODE  AS  '  APPT,  COUNT'  IN  84  PV1_TIME  AS  'TIME, COUNT'  IN 
BY  CLINIC  AS  'CLINIC  BY  CL_TITLE  AS  '  CLINIC,  NAME' 

BY  PROV_ID  AS  'PROV,  ID.' 

BY  PV1_TIME  AS  '  PROVl,  TIME  ' 

BY  APT_STA  AS  '  APPT,  STATUS'  IN  65 

IF  CLINIC  EQ  &&CLN 

IF  VISIT_DATE  FROM  &&ST  TO  &&END 

IF  PROV_ID  EQ  &&PROV 

ON  PV1_TIME  SKIP-LINE 

ON  PROV_ID  SUBTOTAL  AS  'PROV  ID' 

ON  PROV_ID  PAGE-BREAK 
END 

JOIN  CLEAR  * 

-RUN 


1 


-* 

-*  PROGRAM:  PROV4.FEX 
-* 

-*  REPORT:  7 
-* 


MODIFIED:  1/14/86  DRB 

MENU  PROGRAM:  RPTCRTl.FEX 


* 

* 

* 

* 

* 


-*********************************************************** 

-* 


-SET  &&RPT  =  'NUMBER  OF  VISITS  FOR  PROVIDER  IN  ALL  CLINICS'; 

EX  RPTCRTl 
-RUN 

-IF  &&RTN  EQ  'X'  GOTO  RTN  ELSE  GOTO  CONT; 

-RTN 

-EXIT 

-CONT 

-IF  &&NITE  EQ  'Z'  THEN  GOTO  ASET  ELSE  GOTO  CONTI; 

-ASET 

-SET  &&ST=&ST; 

-SET  &&END=&END; 

-SET  &&PROV=&PROV; 

-CONTI 

JOIN  CLINIC  IN  VISIT  TO  CLINIC  IN  CLINIC  AS  JJOIN 
JOIN  PROV_ID  IN  VISIT  TO  PROV_ID  IN  PROVIDER  AS  JJOINl 
TABLE  FILE  VISIT 
HEADING  CENTER 

"NUMBER  OF  VISITS  FOR  <PROV_LST_NME  IN  ALL  CLINICS  " 

"FROM  &4ST  TO  &4END  </2" 

COUNT  LITHO_CODE  COLUMN-TOTAL  AS  'VISIT, COUNT'  IN  75 

BY  PROV_ID  AS  'PROVIDER,  ID.'  IN  10 

BY  PROV_LST_NME  AS  'PROVIDER,  NAME'  IN  20 

BY  CLINIC  IN  35  BY  CL_TITLE  AS  '  CLINIC  NAME  '  IN  45 

IF  PROV_ID  EQ  &&PROV 

IF  VISIT_DATE  FROM  &&ST  TO  &&END 

ON  PROV_ID  PAGE-BREAK 

END 

JOIN  CLEAR  * 

-RUN 


\ 


1 


PROVIDER. MAS 


FILE=PROVIDER, SUFFIX=FOC 

SEGNAME=PROVIDER, SEGTYPE=S1 

FIELD=PROV_ID , PROVID , A5 , FIELDTYPE=I , $ 
FIELD=PROV_DATE , PROVDATE , I6YMD, $ 
FIELD=PROV_LST_2»lE ,  PRLNME ,  A16 ,  $ 
FIELD=PROV_FST_NME , PRFNME , A13 , $ 
FIELD=PROV_INIT , PRINIT , A1 , $ 
FIELD=PROV_STAT , PRSTAT , A1 , $ 
FIELD=PROV_CATEG , PRCATEG , A2 , $ 
FIELD=PROV_PRPOS , PRPOS , A2 , $ 
FIELD=PROV_PAYGR, PRPAYGR, A2 , $ 
FIELD=PROV_JOBCODE , PRJCODE , A7 , $ 
FIELD=PROV_SSN , PRSSN , A9 , $ 
FIELD=PROV_LITHO , PRLTH , A8 , $ 

END 

DBA»=LUGNUT,  $ 

USER=NUTMEG,  ACCESS=RW,  $ 


1 


-It************************************************** 
-*  * 


-*  PROGRAM:  RPTCRT.FEX 
-* 

-*  FOR  REPORTS:  1,  2,  3,  4,  5,  6 


D  BOLLING  * 
* 

4/21/86  * 


-*  * 
-*************************************************** 


-START 

SET  ALL  =  ON 

-IF  &&NITE  EQ  'Z'  GOTO  EXITIT; 

-SET  &MSG  =  IF  &&NITE  EQ  'Y'  THEN 

•SCREENING  CRITERIA  FOR  NIGHT  TIME  PROCESSING* 

_  II. 

» 

-* 


ELSE 


-GOTO  CLRIT 

-SCR 

-* 


-CRTFORM 


<25  REPORT  CRITERIA  SELECTION*' 


.11  II 
_ii  II 

.11  II 
.11  II 
.11 

.11  11 
.11  II 
.11 
.11 

.11  II 
.H  II 
.W 

.11  II 
.11  II 


<25  REPORT:  <D.&&RPT*' 


ENTER  THE  CLINIC  CODE 


VISIT  DATE  FROM  (YMD) 
TO  (YMD) 


ENTER  A  DESIRED  PROVIDER  CODE  : 


•"ENTER  'X' 
.11  n 


TO  RETURN  TO  PRIOR  MENU: 


<.IRHWT.&&CLN>** 

<.IRHWT.&&ST>" 

<.IRHWT.&&END>’* 

<.IRHWT.&&PROV>" 

<.IRHW.&&RTN** 


-"  <.HYD.SiMSG" 

-IF  fifiiRTN  EQ  »X*  THEN  GOTO  XEXIT; 

-SET  &&CLN  =  IF  &&CLN  EQ  '  '  THEN  *$$$$'  ELSE  (SfiiCLN) ; 

-SET  &&PROV  =  IF  &&PROV  EQ  *  *  THEN  *$$$$$*  ELSE  (&&PROV) ; 

-IF  (  &&ST  GE  *840101*  AND  44ST  LE  *991230*  )  OR 
44ST  EQ  *$$$$$$*  GOTO  GOODST; 

-SET  4MSG  =  *  START  DATE  IS  INVALID  -  PLEASE  ENTER  IN  YYMMDD  FORMAT'; 

-GOTO  SCR 

-GOODST 

-IF  (  44END  GE  *840101*  AND  44END  LE  *991230*  )  OR 
44END  EQ  *$$$$$$*  GOTO  GOODEND; 

-SET  4MSG  =  'ENDING  DATE  IS  INVALID  -  PLEASE  ENTER  IN  YYMMDD  FORMAT'; 

-GOTO  SCR 

-GOODEND 

-TYPE 

-TYPE 
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-TYPE 

-TYPE 

-TYPE 

REPORT  IS  NOW 

PROCESSING 

-TYPE 

-TYPE 

SELECTION 

-TYPE 

-TYPE 

DATES 

;  FROM  &SiST 

-TYPE 

PROVIDER 

;  4&PR0V 

-TYPE 

CLINIC 

:  &&CLN 

-TYPE 

-TYPE 

-TYPE 

-TYPE 

&fiiRPT 

-SET  1 

S<StRTN='0'  ; 

-EXIT 

-CLRIT 

-SET  St&ST  *  ' 
-SET  &&END  =  ' 
-SET  &&PROV  =  ' 
-SET  &&CLN  =  * 
-SET  &&RTN=  '  ' 
-GOTO  SCR 
-XEXIT 

-SET  &&RTN='X'; 
-EXIT 
-EXITIT 
-EXIT 


OR  NIGHT  REPORT  BEING  STACKED 
CRITERIA 

TO  &&END 


2 


* 


-*  PROGRAM:  RPTCRTl.FEX 
-* 

-*  FOR  REPORTS:  1 ,  8 


D  BOLLING  * 

* 

4/21/86  * 

* 


^h** *****************************************  ******* 

-START 

SET  ALL  =  ON 

-IF  &&NITE  EQ  'Z'  GOTO  EXITIT; 

-SET  &MSG  =  IF  &&NITE  EQ  'Y'  THEN 

-  'SCREENING  CRITERIA  FOR  NIGHT  TIME  PROCESSING*  ELSE  ' 


-GOTO  CLRIT 
-SCR 


-CRTFORM 

-"  <25  REPORT  CRITERIA  SELECTION" 

_ii  II 
_ii  II 


*» 

II 

II 

II 

N 

II 

If 

n 

If 

n 

If 

11 

If 

If 

If 

II 

II 

If 

,11 

If 

<25  REPORT:  <D.&&RPT" 


VISIT  DATE  FROM  (YMD) 
TO  (YMD) 


ENTER  A  DESIRED  PROVIDER  CODE 


<.IRHWT.&S<ST>" 

<.IRHWT.&&END>" 


<.IRHWT.&&PROV>" 


-"  ENTER  'X'  TO  RETURN  TO  PRIOR  MENU:  <.IRHWT. &&RTN" 

_ii  II 


-"  <.HYD.&MSG" 

-IF  &&RTN  EQ  'X'  GOTO  XEXIT; 

-SET  &&PROV  =  IF  &&PROV  EQ  '  '  THEN  •$$$$$'  ELSE  (Sc&PROV)  ; 

-IF  (  &&ST  GE  '840101'  AND  &&ST  LE  '991230'  )  OR 
&&ST  EQ  '$$$$$$'  GOTO  GOODST; 

-SET  &MSG  =  'START  DATE  IS  INVALID  -  PLEASE  ENTER  IN  YYMMDD  FORMAT'; 

-GOTO  SCR 

-GOODST 

-IF  (  &&END  GE  '840101'  AND  &&END  LE  *991230'  )  OR 
&&END  EQ  '$$$$$$'  GOTO  GOODEND; 

-SET  &MSG  =  'ENDING  DATE  IS  INVALID  -  PLEASE  ENTER  IN  YYMMDD  FORMAT'; 

-GOTO  SCR 

-GOODEND 

-TYPE 

-TYPE 

-TYPE 

-TYPE 

-TYPE  REPORT  IS  NOW  PROCESSING  OR  NIGHT  REPORT  BEING  STACKED 
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-TYPE 

-TYPE  SELECTION  CRITERIA 

-TYPE 

-TYPE  DATES  :  FROM  &&ST  TO  &&END 

-TYPE  PROVIDER:  &&PROV 

-TYPE 

-TYPE 

-TYPE 

-TYPE  &&RPT 

-EXIT 
-* 

-XEXIT 

-EXIT 

-* 

-CLRIT 
-SET  &&RTN=' 

-SET  &&ST  =  •  ' ; 

-SET  &&END  =  •  •  ; 

-SET  &&PROV  =  '  • ; 

-SET  &&CLN  =  '  ' ; 

-GOTO  SCR 

-EXITIT 

-EXIT 


!• 


2 


-*  PROGRAM:  RPTCRT2.FEX 
-* 

-*  FOR  REPORTS:  10 


MODIFIED:  1/14/86  DRB  * 

4/21/86  DRB  * 

* 


-It********************************************************** 

-START 

SET  ALL  =  ON 
-* 

-IF  &&NITE  EQ  'Z'  GOTO  EXITIT; 

-SET  &MSG  =  IF  &&NITE  EQ  'Y*  THEN 

-  'SCREENING  CRITERIA  FOR  NIGHT  TIME  PROCESSING'  ELSE  '  '; 

-* 

-GOTO  CLRIT 

-SCR 

-* 

-CRTFORM 

-"  <25  REPORT  CRITERIA  SELECTION" 


<25  REPORT:  <D.&&RPT" 


ENTER  THE  PATIENT  CATEGORY  :  <. IRHWT. &&CAT>" 


-"  VISIT  DATE  FROM  (YMD)  :  <. IRHWT. &iST>" 

-"  TO  (YMD)  :  <. IRHWT. &&END>" 

_ll  H 
_ll  H 

-"  ENTER  NAME  OF  SITE  FORT  :  <. IRHWT. &&FT>" 

_•!  H 
_ll  II 

-"ENTER  'X'  TO  RETURN  TO  PRIOR  MENU:  < . IRHW. &&RTN" 

_ii  II 

-"  <.HYD.&MSG" 

-IF  &&RTN  EQ  'X'  THEN  GOTO  XEXIT; 

-SET  &&CAT=IF  &&CAT  EQ  '  '  THEN  '$$$'  ELSE  &&CAT; 

-IF  (  &&ST  GE  '840101*  AND  &&ST  LE  '991230*  )  GOTO  GOODST; 

-IF  &&FT  NE  '  '  GOTO  GOODST  ELSE  GOTO  FTMSG; 

-SET  &MSG  =  ' START  DATE  IS  INVALID  -  PLEASE  ENTER  IN  YYMMDD  FORMAT ' ; 

-GOTO  SCR 

-FTMSG 

-SET  &MSG= ' PLEASE  ENTER  NAME  OF  THE  FORT  OR  LOCATION ' ; 

-GOTO  SCR 
-GOODST 

-IF  (  &&END  GE  '840101'  AND  &&END  LE  *991230'  )  OR 
fiSEND  EQ  '$$$$$$'  GOTO  GOODEND; 

-SET  &MSG  =  'ENDING  DATE  IS  INVALID  -  PLEASE  ENTER  IN  YYMMDD  FORMAT'; 

-GOTO  SCR 

-GOODEND 


1 


-TYPE 

-TYPE 

-TYPE 

-TYPE 

-TYPE  REPORT  IS  NOW  PROCESSING  OR  NIGHT  REPORT  BEING  STACKED 
-TYPE 

"1‘ype  selection  criteria 

-TYPE 

-TYPE  DATES  :  FROM  &&ST  TO  &&END 

-TYPE  PATIENT  CATEGORY:  &&CAT 

-TYPE  FORT:  &&FT 

-TYPE 

-TYPE 

-TYPE 

-TYPE  &&RPT 

-SET  &&RTN='0'; 

-EXIT 

-CLRIT 

-SET  &&ST  =  '  •  ; 

-SET  S.&END  =  '  •  ; 

-SET  &&CAT  =  '  ' ; 

-SET  &&FT  =  •  •  ; 

-SET  &&RTN=  '  • ; 

-GOTO  SCR 
-XEXIT 

-SET  &&RTN='X'; 

-EXIT 

-EXITIT 

-EXIT 


2 


-* 

* 

-* 

-* 

PROGRAM:  RPTCRT3.FEX 

D  BOLLING 

* 

* 

-* 

-* 

FOR  REPORTS:  11 

4/21/86 

* 

* 

—  *************:k***4t*******4t*:k****A*ir4t***************4t*A* 

-START 

SET  ALL  =  ON 

-SET  &&LOCl='  •; 

-SET  &&LOC2='  '; 

-SET  &fiiLOC3='  •; 

-SET  &&LOC4='  '; 

-SET  &UICM=' ENTER  UNIT  ID  CODE  (UP  TO  4) 

-* 

-IF  &&NITE  EQ  ‘Z*  GOTO  EXITIT; 

-SET  StMSG  =  IF  &&NITE  EQ  'Y'  THEN 

-  'SCREENING  CRITERIA  FOR  NIGHT  TIME  PROCESSING*  ELSE  '  ' 
-GOTO  CLRIT 

-SCR 

-* 

-CRTFORM 

<25  REPORT  CRITERIA  SELECTION" 

_ii  II 
.11  II 

-"  <25  REPORT:  <D.&&RPT" 

_ii  II 


-"  ENTER  NAME  OF  UNIT  :  <.lRHWT.&SiFT>" 

-"<D.iUICM  <.IRHWT.&&LOCl  < .  IRHWT. &&LOC2  <.  IRHWT. &JcLOC3  < .  IRHWT. &&LOC4 
-"  ENTER  THE  PATIENT  CATEGORY  :  <. IRHWT. &&CAT>" 

_ii  II 
.11  II 

-"  VISIT  DATE  FROM  (YMD)  :  <. IRHWT. &fitST>" 

-"  TO  (YMD)  ;  <. IRHWT. &&END>" 

.11  II 

.n  II 


.11  II 
.11  II 

-"  ENTER  'X'  TO  EXIT 

.11  II 


<.IRHW.&&RTN" 


-"  <.HYD.&MSG" 

-IF  St&RTN  EQ  'X'  THEN  GOTO  XEXIT; 

-IF  S&LOCl  EQ  '  '  GOTO  ST  ELSE  GOTO  SKIP; 

-ST 

-SET  &&LOC2  =  •$$$$$$'; 

-SET  &&LOC4  =  '$$$$$$•; 

-SET  4SLOC1  =  •$$$$$$•; 

-SET  &&LOC3  =  •$$$$$$•; 

-SKIP 

-IF  &&CAT  NE  '  '  GOTO  GOODST  ELSE  GOTO  CATMSG; 
-IF  &&FT  NE  '  •  GOTO  GOODST  ELSE  GOTO  FTMSG; 
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-IF  (  &&ST  GE  '840101'  AND  &&ST  LE  '991230'  )  GOTO  GOODST; 

-SET  iMSG  =  'START  DATE  IS  INVALID  -  PLEASE  ENTER  IN  YYMMDD  FORMAT'; 

-GOTO  SCR 

-CATHSG 

-SET  &MSG» ' YOU  MUST  ENTER  A  PATIENT  CATEGORY ' ; 

-GOTO  SCR 
-FTMSG 

-SET  &MSG= ' PLEASE  ENTER  NAME  OF  THE  FORT  OR  LOCATION ' ; 

-GOTO  SCR 
-GOODST 

-IF  (  &&END  GE  '840101'  AND  &&END  LE  '991230'  )  OR 
&&END  EQ  '$$$$$$'  GOTO  GOODEND; 

-SET  &MSG  =  'ENDING  DATE  IS  INVALID  -  PLEASE  ENTER  IN  YYMMDD  FORMAT'; 

-GOTO  SCR 

-GOODEND 

-TYPE 

-TYPE 

-TYPE 

-TYPE 

-TYPE  REPORT  IS  NOW  PROCESSING  OR  NIGHT  REPORT  BEING  STACKED 
-TYPE 

-TYPE  SELECTION  CRITERIA 

-TYPE 

-TYPE  DATES  :  FROM  fclitST  TO  &&END 

-TYPE  PATIENT  CATEGORY:  &&CAT 

-TYPE  FORT;  &4FT 

-TYPE 

-TYPE 

-TYPE 

-TYPE  &&RPT 

-SET  4&RTN='0'; 

-EXIT 

-CLRIT 

-SET  44L0C1='  '; 

-SET  44LOC2='  '; 

-SET  44LOC3='  '; 

-SET  44LOC4='  '; 

-SET  44ST  =  '  ' ; 

-SET  44END  =  '  • ; 

-SET  44CAT  =  '  ' ; 

-SET  44FT  =  '  ' ; 

-SET  44RTN=  '  ' ; 

-GOTO  SCR 
-XEXIT 

-SET  44RTN='X'; 

-EXIT 

-EXITIT 

-EXIT 


2 


-**************************************************** 


* 

-* 

-* 

PROGRAM:  RPTCRT4.FEX 

D  BOLLING 

* 

* 

-* 

-* 

FOR  REPORTS;  12 

4/21/86 

* 

* 

-a*************************************************** 

-START 

SET  ALL  =  ON 

-IF  &&NITE  EQ  'Z'  GOTO  EXITIT; 

-SET  &MSG  =  IF  &&NITE  EQ  'Y'  THEN 

-  'SCREENING  CRITERIA  FOR  NIGHT  PROCESSING*  ELSE  ' 

-* 

-GOTO  CLRIT 
-SCR 
-* 


-CRTFORM 


.11 

<25  REPORT  CRITERIA 

It 

SELECTION" 

.It 

It 

.11 

It 

.11 

II 

.n 

.11 

.It 

ENTER  TITLE  OF  REPORT 

ENTER  CLINIC  (UCA) 

It 

• 

• 

• 

• 

<.IRHWT.&&RP>" 

<.IRHWT.&&CLN>" 

.11 

II 

.It 

.It 

.It 

VISIT  DATE  FROM  (YMD) 
TO  (YMD) 

II 

• 

• 

• 

« 

<.IRHWT.&&ST>" 

<.IRHWT.&&END>" 

.It 

II 

.11 

II 

.11 

n 

.11 

.11 

ENTER  TO  EXIT 

II 

• 

• 

<.IRHW.&&RTN" 

.11 

<.HYD.&MSG” 

-IF  &&RTN  EQ  'X'  THEN  GOTO  XEXIT; 

-SET  &&CLN=IF  &&CLN  EQ  '  '  THEN  '$$$'  ELSE  &&CLN; 

-IF  (  &&ST  GE  '840101'  AND  &&ST  LE  '991230'  )  GOTO  GOODST; 

-IF  &&RP  NE  '  '  GOTO  GOODST  ELSE  GOTO  FTMSG; 

-SET  &MSG  =  'START  DATE  IS  INVALID  -  PLEASE  ENTER  IN  YYMMDD  FORMAT' 

-GOTO  SCR 

-FTMSG 

-SET  &MSG=' PLEASE  ENTER  REPORT  TITLE  DESIRED'; 

-GOTO  SCR 
-GOODST 

-IF  (  &&END  GE  '840101'  AND  &&END  LE  '991230'  )  OR 
&&END  EQ  '$$$$$$'  GOTO  GOODEND; 

-SET  &MSG  =  'ENDING  DATE  IS  INVALID  -  PLEASE  ENTER  IN  YYMMDD  FORMAT 

-GOTO  SCR 

-GOODEND 

-TYPE 

-TYPE 


1 


-TYPE 

-TYPE 

-TYPE  REPORT  IS  NOW  PROCESSING  OR  NIGHT  REPORT  BEING  STACKED 
-TYPE 

-TYPE  SELECTION  CRITERIA 

-TYPE 

-TYPE  DATES  :  FROM  &&ST  TO  &&END 

-TYPE  CLINIC  ;  &&CIK 

-TYPE 

-TYPE 

-TYPE 

-TYPE  St&RP 

-SET  Si&RTN=s'0'; 

-EXIT 

-CLRIT 

-SET  &&ST  *  '  '  ; 

-SET  &&CLN-  •  ' ; 

-SET  &&END  =  '  ' ; 

-SET  &&RP  =  '  ' ' 

-SET  fit&RTN=  '  *  ; 

-GOTO  SCR 
-XEXIT 

-SET  fii&RTN='X'; 

-EXIT 

-EXITIT 

-EXIT 


2 


-************************************************************ 
-*  * 


-* 

PROGRAM:  RPTCRT5.FEX 

WRITTEN : 

1/14/86 

DRB 

* 

* 

-* 

-* 

FOR  REPORTS:  9 

MODIFIED 

4/21/86 

DRB 

* 

* 

-hit********************************************************** 

-* 

-START 

SET  ALL  =  ON 

-IF  &&NITE  EQ  'Z'  GOTO  EXITIT; 

-SET  &MSG  =  IF  &&NITE  EQ  'Y'  THEN 

•SCREENING  CRITERIA  FOR  NIGHT  TIME  PROCESSING'  ELSE 

—  It. 

f 

-* 

-* 

-GOTO  CLRIT 
-SCR 
-* 


-CRTFORM 


.11 

.If 

ft 

<25  REPORT  CRITERIA  SELECTION" 

.11 

If 

.11 

ff 

<25  REPORT: 

<D.&&RPT" 

.11 

ff 

.If 

.ff 

ff 

ENTER  THE 

CLINIC  CODE  : 

<.IRHWT.&&CLN>" 

.If 

If 

.If 

.11 

.If 

If 

VISIT  DATE  FROM  (YMD)  : 

TO  (YMD)  : 

<.IRHWT.&&ST>" 

<.IRHWT.&&END>" 

.11 

If 

.If 

If 

.ff 

If 

-"ENTER  • 

.If  ti 

X'  TO  RETURN 

TO  PRIOR  MENU: 

<.IRHW.&6RTN" 

.If 

<.HYD. 

&MSG" 

-IF  &&RTN  EQ  'X'  THEN  GOTO  XEXIT; 

-SET  &&CLN  =  IF  &&CLN  EQ  '  '  THEN  '$$$$'  ELSE  (&&CLN) ; 

-IF  (  &&ST  GE  '840101'  AND  &&ST  LE  '991230'  )  OR 
&&ST  EQ  •$$$$$$'  GOTO  GOODST; 

-SET  &MSG  =  'START  DATE  IS  INVALID  -  PLEASE  ENTER  IN  YYMMDD  FORMAT' 

-GOTO  SCR 

-GOODST 

-IF  (  &&END  GE  '840101'  AND  &&END  LE  '991230'  )  OR 
&&END  EQ  '$$$$$$'  GOTO  GOODEND; 

-SET  4MSG  =  'ENDING  DATE  IS  INVALID  -  PLEASE  ENTER  IN  YYMMDD  FORMAT 

-GOTO  SCR 

-GOODEND 

-TYPE 


1 


-TYPE 

-TYPE 

-TYPE 

-TYPE 

-TYPE 

-TYPE 

-TYPE 

-TYPE 

-TYPE 

-TYPE 

-TYPE 

-TYPE 

-TYPE 


REPORT  IS  NOW  PROCESSING  OR  NIGHT  REPORT  BEING  STACKED 

SELECTION  CRITERIA 

DATES  :  FROM  &&ST  TO  SS.END 

CLINIC  :  &&CLN 


&&RPT 


-SET  &&RTN=»0'; 

-EXIT 

-CLRIT 

-SET  &&ST  =  ' 
-SET  &&END  =  ' 
-SET  &&PROV  =  • 
-SET  &&CLN  «  ' 
-SET  &4RTN=  '  • ; 
-GOTO  SCR 
-XEXIT 

-SET  &&RTN='X'; 
-EXIT 
-EXITIT 
-EXIT 


2 


—  ******4tA*4t**4r*4t*4t******ir**********4t*************4t**4t4t*** 

-*  RXXCCLD.FEX  D  R  BOLLING  05/06/87  * 

-*  4t 

-*  DUMPS  CLINIC  SEGMENTS  TO  FLAT  FILE  FOR  CORRECTION  * 
-*  REVISED  FOR  NEW  DESIGN  FORMS  * 

-*  CALLED  FROM  RXXFCCL.FEX  ♦ 

— A******************************************************* 

-CRTCLEAR 

END 

USE 

ErVISIT.FOC 

END 

-SET  ALL=ON; 

-SET  &&RECTYPE= ' 1 ’ ; 

DEFINE  FILE  VISIT 

RECTP/A1= • &&RECTYPE ' ; 

CLINEW/A4='&SiCLNEW'  ; 

END 

-RUN 

-TYPE  RECORDS  TYPE  1  BEING  PROCESSED 
FILEDEF  HOLD  DISK  CtHOLD.FTM 
TABLEF  FILE  VISIT. TIMEl 

PRINT  RECTP  CLINEW  VDATE  PROVl  PTID  SEG.LITHO 

IF  CLINIC  EQ  &fiiCLOLD 

ON  TABLE  SAVE  AS  HOLD 

END 

-RUN 

-SET  &&RECTYPE= ' 2 ' ; 

DEFINE  FILE  VISIT  ADD 
RECTP/A1= ' i&RECTYPE ' ; 

CLINEW/A4= ' &&CLNEW' ; 

PAD/A30=' . '  ; 

END 

-RUN 

-TYPE  RECORDS  TYPE  2  BEING  PROCESSED 
FILEDEF  HOLD  DISK  C:HOLD.FTM  APPEND 
TABLEF  FILE  VISIT. PCODE 

PRINT  RECTP  CLINEW  VDATE  PROVl  PTID  LITHO  PCODE  PRCODE  PAD 

IF  CLINIC  EQ  &&CLOLD 

ON  TABLE  SAVE  AS  HOLD 

END 

-RUN 

-SET  &&RECTYPE= ' 3 ' ; 

DEFINE  FILE  VISIT  ADD 
RECTP/A1= '  Si&RECTYPE '  ; 

CLINEW/A4= ' &&CLNEW' ; 

PAD/A35=' . '  ; 

END 

-RUN 

-TYPE  RECORDS  TYPE  3  BEING  PROCESSED 
FILEDEF  HOLD  DISK  C:HOLD.FTM  APPEND 
TABLEF  FILE  VISIT. SPCC 
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PRINT  RECTP  CLINEW  VDATE  PROVl  PTID  LITHO  SPCC  PAD 

IF  CLINIC  EQ  &&CLOLD 

ON  TABLE  SAVE  AS  HOLD 

END 

-RUN 

-SET  &&RECTYPE= ' 4 • ; 

DEFINE  FILE  VISIT  ADD 
RECTP/ Al= ' &&RECTYPE ' ; 

CLINEW/A4=  * i&CLNEW • ; 

PAD/A31®' . •  ; 

END 

-RUN 

-TYPE  RECORDS  TYPE  4  BEING  PROCESSED 
FILEDEF  HOLD  DISK  C:HOLD.FTM  APPEND 
TABLEF  FILE  VISIT. OTHER 

PRINT  RECTP  CLINEW  VDATE  PROVl  PTID  LITHO  OTHER  PAD 

IF  CLINIC  EQ  &&CLOLD 

ON  TABLE  SAVE  AS  HOLD 

END 

-RUN 

-SET  &&RECTYPE='5' ; 

DEFINE  FILE  VISIT  ADD 
RECTP/A1= ' &&RECTYPE ' ; 

CLINEW/A4= • &&CLNEW ' ; 

PAD/A2= • . . ' ; 

END 

-RUN 

-TYPE  RECORDS  TYPE  5  BEING  PROCESSED 
FILEDEF  HOLD  DISK  C:HOLD.FTM  APPEND 
TABLEF  FILE  VISIT. UIC 

PRINT  RECTP  CLINEW  VDATE  PROVl  PTID  LITHO  SEG.UIC  PAD 

IF  CLINIC  EQ  SScCLOLD 

ON  TABLE  SAVE  AS  HOLD 

END 

-RUN 

-SET  &&RECTYPE= ' 6 ' ; 

DEFINE  FILE  VISIT  ADD 
RECTP/ Al= ' fiSRECTYPE ' ; 

CLINEW/A4=' &&CLNEW' ; 

PAD/ A3  5=' . '  ; 

END 

-RUN 

-TYPE  RECORDS  TYPE  6  BEING  PROCESSED 
FILEDEF  HOLD  DISK  CrHOLD.FTM  APPEND 
TABLEF  FILE  VISIT. SPROG 

PRINT  RECTP  CLINEW  VDATE  PROVl  PTID  LITHO  SPROG  PAD 

IF  CLINIC  EQ  &&CLOLD 

ON  TABLE  SAVE  AS  HOLD 

END 

-RUN 

-SET  &&RECTYPE= ’ 7 ' ; 

DEFINE  FILE  VISIT  ADD 
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RECTP/A1= • &&RECTYPE ' ; 

CLINEW/A4='&&CLNEW' ; 

PAD/A31=' . •  ; 

END 

-RUN 

-TYPE  RECORDS  TYPE  7  BEING  PROCESSED 
FILEDEF  HOLD  DISK  CrHOLD.FTM  APPEND 
TABLEF  FILE  VISIT. DX2CODE 

PRINT  RECTP  CLINEW  VDATE  PROVl  PTID  LITHO  DIAG2_CODE  PAD 

IF  CLINIC  EQ  &&CLOLD 

ON  TABLE  SAVE  AS  HOLD 

END 

-RUN 

-SET  &&RECTYPE= ' 8 • ; 

DEFINE  FILE  VISIT  ADD 
RECTP/ Al= ' &&RECTYPE ' ; 

CLINEW/ A4= ' &&CLNEW • ; 

PAD/ A3  5=  ' . '  ; 

END 

-RUN 

-TYPE  RECORDS  TYPE  8  BEING  PROCESSED 
FILEDEF  HOLD  DISK  C:HOLD.FTM  APPEND 
TABLEF  FILE  VISIT. ASSESMNT 

PRINT  RECTP  CLINEW  VDATE  PROVl  PTID  LITHO  ASSESMNT  PAD 

IF  CLINIC  EQ  Si&CLOLD 

ON  TABLE  SAVE  AS  HOLD 

END 

-RUN 

-SET  &fi.RECTYPE= ' 9 ' ; 

DEFINE  FILE  VISIT  ADD 
RECTP/ Al= '  St&RECTYPE '  ; 

CLINEW/A4='&&CLNEW' ; 

PAD/A34=' . •  ; 

END 

-RUN 

-TYPE  RECORDS  TYPE  9  BEING  PROCESSED 
FILEDEF  HOLD  DISK  C:HOLD.FTM  APPEND 
TABLEF  FILE  VISIT. DISP 

PRINT  RECTP  CLINEW  VDATE  PROVl  PTID  LITHO  DISP  PAD 

IF  CLINIC  EQ  &&CLOLD 

ON  TABLE  SAVE  AS  HOLD 

END 

-RUN 
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-h************************************************************ ******** 

-*  RXXCORL.FEX  D  R  BOLLING  05/06/87 

-* 

-*  LOADS  CORRECTED  HOLD  FILE  BACK  TO  VISIT  FILE 
-*  REVISED  FOR  NEW  FORM  DESIGN 

-*  CALLED  FROM  RXXFCCL.FEX  OR  RXXFCPR.FEX  OR  RXXFCPA.FEX 
-* 

-********************************************************************* 
FILEDEF  MODIF  DISK  C:HOLD.FTM 
FILEDEF  VISITLG  DISK  C: VISIT. LOG 
-* 

-START 

DOS  STATE  E : VISIT. FOC 
-RUN 

-IF  &RETCODE  NE  0  GOTO  UNEW  ; 

USE  E: VISIT. FOC 
END 

-GOTO  CONT 
-UNEW 

USE  E;  VIS  IT.  FOC  NEW 
END 

CREATE  FILE  VISIT 
-CONT 
-CRTCLEAR 
MODIFY  FILE  VISIT 
-* 

LOG  DUPL  MSG  OFF 
LOG  NOMATCH  MSG  OFF 

TYPE  AT  START  ON  VISITLG  ”  CORRECTION  ERROR  LOG  September  10,  1988 
TYPE  AT  START  "LOADING  CORRECTED  DATA  September  10,  1988  " 

CHECK  OFF 
COMPUTE 

RECTYPE/Al  =; 

FIXFORM  RECTYPE/Al  CLINIC/C4  VDATE/C6  PROV1/C5 

FIXFORM  PTID/Cll  LITHO/C8  X36 

- - 

-*  LOAD  OF  THE  VISIT  KEY  DATA  FOR  ALL  FORMS. 

- - 

MATCH  CLINIC 

ON  MATCH  CONTINUE 
ON  NOMATCH  INCLUDE 
ON  NOMATCH  GOTO  TESTRECT 
MATCH  VDATE 

ON  MATCH  CONTINUE 
ON  NOMATCH  INCLUDE 
ON  NOMATCH  GOTO  TESTRECT 
MATCH  PROVl 

ON  MATCH  CONTINUE 
ON  NOMATCH  INCLUDE 
ON  NOMATCH  GOTO  TESTRECT 
MATCH  PTID 

ON  MATCH  CONTINUE 


ON  NOMATCH  INCLUDE 
ON  NOMATCH  GOTO  TESTRECT 
MATCH  LITHO 

ON  MATCH  GOTO  TESTRECT 
ON  NOMATCH  INCLUDE 
ON  NOMATCH  GOTO  TESTRECT 

-* 

CASE  TESTRECT 
COMPUTE 

CLINIC  =  CLINIC; 

VDATE  =  VDATE ; 

PROVl  =  PROVl ; 

PTID  =  PTID; 

LITHO  =  LITHO ; 

IF  RECTYPE  EQ  *1'  GOTO  PROCITP; 
IF  RECTYPE  EQ  '2'  GOTO  PROC2TP; 
IF  RECTYPE  EQ  '3'  GOTO  PROC3TP; 
IF  RECTYPE  EQ  '4'  GOTO  PROC4TP; 
IF  RECTYPE  EQ  '5'  GOTO  PROC5TP; 
IF  RECTYPE  EQ  '6'  GOTO  PROC6TP; 
IF  RECTYPE  EQ  '7'  GOTO  PROC7TP; 
IF  RECTYPE  EQ  '8'  GOTO  PROC8TP; 
IF  RECTYPE  EQ  '9'  GOTO  PROC9TP; 
ENDCASE 


_* - * 

CASE  PROCITP 

-*  • 
-*  COMMON  FORM 

-*  RECORD  TRANSACTION  TYPE  '1'  PROCESSING  BEGINS 

— - - - - - - - — - - - - — — ___ — •>— — * 


FIXFORM  X-36  FNUM/2  VCNT/1  TIMEl/3  PROV2/5  TIME2/3  PROV2RES/1 

FIXFORM  APPSTAT/1  PLACE/ 1  REFERAL/4  JOBREL/1  DUTY/1  QTR/1 

FIXFORM  PROF/1  NAVAIL/1  ADMIT/1  ILLN/1  INJ/1  PURP/1 

FIXFORM  RULE/1  DXlCODE/5 

MATCH  CLINIC 

ON  MATCH  CONTINUE 
ON  NOMATCH  REJECT 
MATCH  VDATE 

ON  MATCH  CONTINUE 
ON  NOMATCH  REJECT 
MATCH  PROVl 

ON  MATCH  CONTINUE 
ON  NOMATCH  REJECT 
MATCH  PTID 

ON  MATCH  CONTINUE 
ON  NOMATCH  REJECT 

-* 

MATCH  LITHO 
ON  MATCH 

UPDATE  FNUM  VCNT  TIMEl  PROV2  TIME2  PROV2RES  APPSTAT 

UPDATE  PLACE  REFERAL  JOBREL  DUTY  QTR  PROF  NAVAIL  ADMIT 

UPDATE  ILLN  INJ  PURP  RULE  DXICODE 
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ON  NOMATCH  REJECT 
ENDCASE 

— _ — - - - * 

CASE  PROC2TP 
FIXFORM  X-36 

FIXFORM  PCODE/5  PRCODE/1 
MATCH  CLINIC 

ON  MATCH  CONTINUE 
ON  NOMATCH  REJECT 
MATCH  VDATE 

ON  MATCH  CONTINUE 
ON  NOMATCH  REJECT 
MATCH  PROVl 

ON  MATCH  CONTINUE 
ON  NOMATCH  REJECT 
MATCH  PTID 

ON  MATCH  CONTINUE 
ON  NOMATCH  REJECT 
MATCH  LITHO 

ON  MATCH  CONTINUE 
ON  NOMATCH  REJECT 
MATCH  PCODE 

ON  MATCH  REJECT 
ON  NOMATCH  INCLUDE 
GOTO  TOP 
ENDCASE 

—  4t  — -  —  —  —  _  —  _  —  —  — —  —  —  —  —  —  —  —  —  —  —  — 

CASE  PROC3TP 
FIXFORM  X-36 
FIXFORM  SPCC/1 
MATCH  CLINIC 

ON  MATCH  CONTINUE 
ON  NOMATCH  REJECT 
MATCH  VDATE 

ON  MATCH  CONTINUE 
ON  NOMATCH  REJECT 
MATCH  PROVl 

ON  MATCH  CONTINUE 
ON  NOMATCH  REJECT 
MATCH  PTID 

ON  MATCH  CONTINUE 
ON  NOMATCH  REJECT 
MATCH  LITHO 

ON  MATCH  CONTINUE 
ON  NOMATCH  REJECT 
MATCH  spec 

ON  MATCH  REJECT 
ON  NOMATCH  INCLUDE 
GOTO  TOP 
ENDCASE 

—  *  —  —  —  —  —  —  —  —  —  —  — —  —  ^  —  — —  —  —  —  —  —  —  —  _  —  —  —  —  —  —  —  —  —  _  —  —  —  —  —  —  —  —  —  —  —  —  —  —  —  —  —  —  —  —  —  * 
CASE  PROC4TP 
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FIXFORM  X-36 
FIXFORM  OTHER/ 5 
MATCH  CLINIC 

ON  MATCH  CONTINUE 
ON  NOMATCH  REJECT 
MATCH  VDATE 

ON  MATCH  CONTINUE 
ON  NOMATCH  REJECT 
MATCH  PROVl 

ON  MATCH  CONTINUE 
ON  NOMATCH  REJECT 
MATCH  PTID 

ON  MATCH  CONTINUE 
ON  NOMATCH  REJECT 
MATCH  LITHO 

ON  MATCH  CONTINUE 
ON  NOMATCH  REJECT 
MATCH  OTHER 

ON  MATCH  REJECT 
ON  NOMATCH  INCLUDE 
GOTO  TOP 
ENDCASE 

-* - * 

CASE  PROC5TP 
FIXFORM  X-36 

FIXFORM  UIC/6  TIMPRl/3  TIMPR2/3  TIMTRl/3  TIMTR2/3  MACT/3  OACT/3 
FIXFORM  RMIL/3  DEPD/3  CIVIL/3  CSHEET/1 
MATCH  CLINIC 

ON  MATCH  CONTINUE 
ON  NOMATCH  REJECT 
MATCH  VDATE 

ON  MATCH  CONTINUE 
ON  NOMATCH  REJECT 
MATCH  PROVl 

ON  MATCH  CONTINUE 
ON  NOMATCH  REJECT 
MATCH  PTID 

ON  MATCH  CONTINUE 
ON  NOMATCH  REJECT 
MATCH  LITHO 

ON  MATCH  CONTINUE 
ON  NOMATCH  REJECT 
MATCH  UIC 

ON  MATCH  REJECT 
ON  NOMATCH  INCLUDE 
GOTO  TOP 
ENDCASE 

—  4t  — -  -  -  -  - - -  - —  — - -  - - - —  - _________________  _  _______  _  ___  _  _ - it 

CASE  PROC6TP 
FIXFORM  X-36 
FIXFORM  SPROG/1 
MATCH  CLINIC 
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ON  MATCH  CONTINUE 
ON  NOMATCH  REJECT 
MATCH  VDATE 

ON  MATCH  CONTINUE 
ON  NOMATCH  REJECT 
MATCH  PROVl 

ON  MATCH  CONTINUE 
ON  NOMATCH  REJECT 
MATCH  PTID 

ON  MATCH  CONTINUE 
ON  NOMATCH  REJECT 
MATCH  LITHO 

ON  MATCH  CONTINUE 
ON  NOMATCH  REJECT 
MATCH  SPROG 

ON  MATCH  REJECT 
ON  NOMATCH  INCLUDE 
GOTO  TOP 
ENDCASE 

CASE  PROC7TP 
FIXFORM  X-36  DX2CODE/5 
MATCH  CLINIC 

ON  MATCH  CONTINUE 
ON  NOMATCH  REJECT 
MATCH  VDATE 

ON  MATCH  CONTINUE 
I#  ON  NOMATCH  REJECT 

MATCH  PROVl 

ON  MATCH  CONTINUE 
ON  NOMATCH  REJECT 
MATCH  PTID 

ON  MATCH  CONTINUE 
ON  NOMATCH  REJECT 
MATCH  LITHO 

ON  MATCH  CONTINUE 
ON  NOMATCH  REJECT 
MATCH  DX2CODE 

ON  MATCH  REJECT 
ON  NOMATCH  INCLUDE 
GOTO  TOP 
ENDCASE 

CASE  PROC8TP 

FIXFORM  X-36  ASSESMNT/1 

MATCH  CLINIC 

ON  MATCH  CONTINUE 
ON  NOMATCH  REJECT 
MATCH  VDATE 

ON  MATCH  CONTINUE 
ON  NOMATCH  REJECT 
MATCH  PROVl 
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ON  MATCH  CONTINUE 
ON  NOMATCH  REJECT 
MATCH  PTID 

ON  MATCH  CONTINUE 
ON  NOMATCH  REJECT 
MATCH  LITHO 

ON  MATCH  CONTINUE 
ON  NOMATCH  REJECT 
MATCH  ASSESMNT 

ON  MATCH  REJECT 
ON  NOMATCH  INCLUDE 
GOTO  TOP 
ENDCASE 

-******************************************************************** 
CASE  PROC9TP 
FIXFORM  X-36  DISP/2 
MATCH  CLINIC 

ON  MATCH  CONTINUE 
ON  NOMATCH  REJECT 
MATCH  VDATE 

ON  MATCH  CONTINUE 
ON  NOMATCH  REJECT 
MATCH  PROVl 

ON  MATCH  CONTINUE 
ON  NOMATCH  REJECT 
MATCH  PTID 

ON  MATCH  CONTINUE 
ON  NOMATCH  REJECT 
MATCH  LITHO 

ON  MATCH  CONTINUE 
ON  NOMATCH  REJECT 
MATCH  DISP 

ON  MATCH  REJECT 
ON  NOMATCH  INCLUDE 
GOTO  TOP 
ENDCASE 

DATA  ON  MODIF 
END 
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-It******************************************************* 

-*  RXXCPAD.FEX  D  R  BOLLING  05/06/87  * 

-*  * 

-*  DUMPS  PATIENT  SEGMENTS  TO  FLAT  FILE  FOR  CORRECTION  * 

-*  REVISED  FOR  NEW  DESIGN  FORMS  * 

CALLED  FROM  RXXFCPA.FEX  * 

-******************************************************** 

-CRTCLEAR 

END 

USE 

E : VISIT. FOC 

END 

-SET  ALL=ON; 

-SET  &&RECTYPE= ' 1 ' ; 

DEFINE  FILE  VISIT 

RECTP/A1= • &&RECTyPE ' ; 

PATNEW/A11= ' &&PANEW • ; 

END 

-RUN 

-TYPE  RECORDS  TYPE  1  BEING  PROCESSED 
FILEDEF  HOLD  DISK  C:HOLD.FTM 
TABLEF  FILE  VISIT. LITHO 

PRINT  RECTP  CLINIC  VDATE  PROVl  PATNEW  SEG. LITHO 

IF  PTID  EQ  &&PAOLD 

ON  TABLE  SAVE  AS  HOLD 

END 

-RUN 

-SET  4&RECTYPE='2'; 

DEFINE  FILE  VISIT  ADD 
RECTP/ Al« • &&RECTYPE ' ; 

PATNEW/A11= ' &&PANEW • ; 

PAD/A30=» . '  ; 

END 

-RUN 

-TYPE  RECORDS  TYPE  2  BEING  PROCESSED 
FILEDEF  HOLD  DISK  ClHOLD.FTM  APPEND 
TABLEF  FILE  VISIT. PROC_CODE 

PRINT  RECTP  CLINIC  VDATE  PROVl  PATNEW  LITHO  PCODE  PRCODE  PAD 

IF  PTID  EQ  &&PAOLD 

ON  TABLE  SAVE  AS  HOLD 

END 

-RUN 

-SET  &&RECTYPE= ' 3 ' ; 

DEFINE  FILE  VISIT  ADD 
RECTP/ Al= ' &&RECTYPE ' ; 

PATNEW/A11= ' &&PANEW ' ;  j 

PAD/ A3  5=' . '? 

END 

-RUN 

-TYPE  RECORDS  TYPE  3  BEING  PROCESSED 
FILEDEF  HOLD  DISK  CrHOLD.FTM  APPEND 

TABLEF  FILE  VISIT. SPCC  j 
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PRINT  RECTP  CLINIC  VDATE  PROVl  PATNEW  LITHO  SPCC  PAD 

IF  PTID  EQ  &&PAOLD 

ON  TABLE  SAVE  AS  HOLD 

END 

-RUN 

-SET  «t&RECTYPE= '  4  '  ; 

DEFINE  FILE  VISIT  ADD 
RECTP/ Al= ’ &&RECTYPE ' ; 

PATNEW/A11= ' &&PANEW ' ; 

PAD/A31-' . '  ; 

END 

-RUN 

-TYPE  RECORDS  TYPE  4  BEING  PROCESSED 
FILEDEF  HOLD  DISK  C:HOLD.FTM  APPEND 
TABLEF  FILE  VISIT. OTHER 

PRINT  RECTP  CLINIC  VDATE  PROVl  PATNEW  LITHO  OTHER  PAD 

IF  PTID  EQ  &&PAOLD 

ON  TABLE  SAVE  AS  HOLD 

END 

-RUN 

-SET  &&RECTYPE= ' 5 ' ; 

DEFINE  FILE  VISIT  ADD 
RECTP/ Al= • &&RECTYPE ' ; 

PATNEW/A11= ' &&PANEW ' ; 

PAD/A2= ' . . ' ; 

END 

-RUN 

-TYPE  RECORDS  TYPE  5  BEING  PROCESSED 
FILEDEF  HOLD  DISK  CtHOLD.FTM  APPEND 
TABLEF  FILE  VISIT. UIC 

PRINT  RECTP  CLINIC  VDATE  PROVl  PATNEW  LITHO  SEG.UIC  PAD 

IF  PTID  EQ  &&PAOLD 

ON  TABLE  SAVE  AS  HOLD 

END 

-RUN 

-SET  &&RECTYPE= ' 6 ' ; 

DEFINE  FILE  VISIT  ADD 
RECTP/A1= ' &&RECTYPE ' ; 

PATNEW/ A1 1= • &  &PANEW ' ; 

PAD/A35=  * . •  ; 

END 

-RUN 

-TYPE  RECORDS  TYPE  6  BEING  PROCESSED 
FILEDEF  HOLD  DISK  ClHOLD.FTM  APPEND 
TABLEF  FILE  VISIT. SPECIAL_PROG 

PRINT  RECTP  CLINIC  VDATE  PROVl  PATNEW  LITHO  SPROG  PAD 

IF  PTID  EQ  &&PAOLD 

ON  TABLE  SAVE  AS  HOLD 

END 

-RUN 

-SET  &&RECTYPE= ' 7 ' ; 

DEFINE  FILE  VISIT  ADD 
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RECTP/A1= • i&RECTYPE ' ; 

PATNEW/A11» ' &&PANEW • ; 

PAD/A31*' . '  ; 

END 

-RON 

-TYPE  RECORDS  TYPE  7  BEING  PROCESSED 
FILEDEF  HOLD  DISK  C:HOLD.FTM  APPEND 
TABLEF  FILE  VISIT. DIAG2_CODE 

PRINT  RECTP  CLINIC  VDATE  PROVl  PATNEW  LITHO  DIAG2_CODE  PAD 

IF  PTID  EQ  &&PAOLD 

ON  TABLE  SAVE  AS  HOLD 

END 

-RUN 

-SET  &&RECTYPE= • 8 ' ; 

DEFINE  FILE  VISIT  ADD 
RECTP/A1= ' &&RECTYPE ' ; 

PATNEW/A11= ' &&PANEW ' ; 

PAD/ A3  5=' . •  ; 

END 

-RUN 

-TYPE  RECORDS  TYPE  8  BEING  PROCESSED 
FILEDEF  HOLD  DISK  CtHOLD.FTM  APPEND 
TABLEF  FILE  VISIT. ASSESMNT 

PRINT  RECTP  CLINIC  VDATE  PROVl  PATNEW  LITHO  ASSESMNT  PAD 

IF  PTID  EQ  &&PAOLD 

ON  TABLE  SAVE  AS  HOLD 

END 

-RUN 

-SET  &&RECTYPE* ' 9 ' ; 

DEFINE  FILE  VISIT  ADD 
RECTP/ Al= ' &&RECTYPE ' ; 

PATNEW/ A1 1= ' S  &PANEW ' ; 

PAD/A34=' . '  ; 

END 

-RUN 

-TYPE  RECORDS  TYPE  9  BEING  PROCESSED 
FILEDEF  HOLD  DISK  C;HOLD.FTM  APPEND 
TABLEF  FILE  VISIT. DISP 

PRINT  RECTP  CLINIC  VDATE  PROVl  PATNEW  LITHO  DISP  PAD 
IF  PTID  EQ  &&PAOLD 
ON  TABLE  SAVE  AS  HOLD 
END 


—  4t*****A4i4t*A*4t4t*4t4t4t**AA*A*A*4i*******4r*A4t**it4t****4!4t4t***4t4t4r 

-*  RXXCPRD.FEX  D  R  BOLLING  05/06/87  * 

-*  * 

-*  DUMPS  PROVIDER  SEGMENTS  TO  FLAT  FILE  FOR  CORRECTION  * 

-*  REVISED  FOR  NEW  DESIGN  FORMS  * 

-*  CALLED  FROM  RXXFCPR.FEX  * 

-CRTCLEAR 

END 

USE 

E : VISIT. FOC 

END 

-SET  ALL=ON; 

-SET  S.&RECTYPE= '  1 '  ; 

DEFINE  FILE  VISIT 

RECTP/A1= ' &&RECTYPE ' ; 

PRONEW/A5= ' &&PRNEW ' ; 

END 

-RUN 

-TYPE  RECORDS  TYPE  1  BEING  PROCESSED 
FILEDEF  HOLD  DISK  C:HOLD.FTM 
TABLEF  FILE  VISIT. TIMEl 

PRINT  RECTP  CLINIC  VDATE  PRONEW  PTID  SEG.LITHO 

IF  PROV_ID  EQ  &&PROLD 

ON  TABLE  SAVE  AS  HOLD 

END 

-RUN 

-SET  &SRECTYPE= ' 2  * ; 

DEFINE  FILE  VISIT  ADD 
RECTP/ Al= ' SfiiRECTYPE • ; 

PRONEW/A5* ' &&PRNEW ' ; 

PAD/A30=' . ’  ; 

END 

-RUN 

-TYPE  RECORDS  TYPE  2  BEING  PROCESSED 
FILEDEF  HOLD  DISK  C:HOLD.FTM  APPEND 
TABLEF  FILE  VISIT. PCODE 

PRINT  RECTP  CLINIC  VDATE  PRONEW  PTID  LITHO  PCODE  PRCODE  PAD 

IF  PROV_ID  EQ  &&PROLD 

ON  TABLE  SAVE  AS  HOLD 

END 

-RUN 

-SET  &&RECTYPE= ' 3 ' ; 

DEFINE  FILE  VISIT  ADD 
RECTP/A1= ' &&RECTYPE ' ; 

PRONEW/A5= ' &&PRNEW ' ; 

PAD/ A3  5=' . '  ; 

END 

-RUN 

-TYPE  RECORDS  TYPE  3  BEING  PROCESSED 
FILEDEF  HOLD  DISK  CrHOLD.FTM  APPEND 
TABLEF  FILE  VISIT. SPCC 
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PRINT  RECTP  CLINIC  VDATE  PRONEW  PTID  LITHO  SPCC  PAD 

IF  PROV_ID  EQ  &&PROLD 

ON  TABLE  SAVE  AS  HOLD 

END 

-RUN 

-SET  i4RECTYPE= • 4 ' ; 

DEFINE  FILE  VISIT  ADD 
RECTP/ Al= • SiRECTYPE • ; 

PRONEW/A5= ' &&PRNEW  * ; 

PAD/A31=' . '  ; 

END 

-RUN 

-TYPE  RECORDS  TYPE  4  BEING  PROCESSED 
FILEDEF  HOLD  DISK  C:HOLD.FTM  APPEND 
TABLEF  FILE  VISIT. OTHER 

PRINT  RECTP  CLINIC  VDATE  PRONEW  PTID  LITHO  OTHER  PAD 

IF  PROV_ID  EQ  SfitPROLD 

ON  TABLE  SAVE  AS  HOLD 

END 

-RUN 

-SET  &&RECTYPE='5' ; 

DEFINE  FILE  VISIT  ADD 
RECTP/ AI= ' &&RECTYPE ' ; 

PRONEW/A5= • &&PRNEW • ; 

PAD/A2=' . . • ; 

END 

-RUN 

-TYPE  RECORDS  TYPE  5  BEING  PROCESSED 
FILEDEF  HOLD  DISK  CtHOLD.FTM  APPEND 
TABLEF  FILE  VISIT. UIC 

PRINT  RECTP  CLINIC  VDATE  PRONEW  PTID  LITHO  SEG.UIC  PAD 

IF  PROV_ID  EQ  &&PROLD 

ON  TABLE  SAVE  AS  HOLD 

END 

-RUN 

-SET  &&RECTYPE= ' 6 ' ; 

DEFINE  FILE  VISIT  ADD 
RECTP/ Al= ' &&RECTYPE ' ; 

PRONEW/ A5= ' &&PRNEW » ; 

PAD/A35=' . '  ; 

END 

-RUN 

-TYPE  RECORDS  TYPE  6  BEING  PROCESSED 
FILEDEF  HOLD  DISK  ClHOLD.FTM  APPEND 
TABLEF  FILE  VISIT. SPROG 

PRINT  RECTP  CLINIC  VDATE  PRONEW  PTID  LITHO  SPROG  PAD 

IF  PROV_ID  EQ  SiSiPROLD 

ON  TABLE  SAVE  AS  HOLD 

END 

-RUN 

-SET  &&RECTYPE= ' 7 ' ; 

DEFINE  FILE  VISIT  ADD 
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RECTP/A1= '  &&RECTYPE '  ; 

PR0NEW/A5=  •  &fi.PRNEW '  ; 

PAD/A31=' . '  ; 

END 

-RUN 

-TYPE  RECORDS  TYPE  7  BEING  PROCESSED 
FILEDEF  HOLD  DISK  ClHOLD.FTM  APPEND 
TABLEF  FILE  VISIT. DX2CODE 

PRINT  RECTP  CLINIC  VDATE  PRONEW  PTID  LITHO  DIAG2_CODE  PAD 

IF  PROV_ID  EQ  &&PROLD 

ON  TABLE  SAVE  AS  HOLD 

END 

-RUN 

-SET  &&RECTYPE= ' 8 ' ; 

DEFINE  FILE  VISIT  ADD 
RECTP/A1= • &&RECTYPE ' ; 

PRONEW/ A5= ' &fi.PRNEW ' ; 

PAD/A35=» . •  ; 

END 

-RUN 

-TYPE  RECORDS  TYPE  8  BEING  PROCESSED 
FILEDEF  HOLD  DISK  ClHOLD.FTM  APPEND 
TABLEF  FILE  VISIT. ASSESMNT 

PRINT  RECTP  CLINIC  VDATE  PRONEW  PTID  LITHO  ASSESMNT  PAD 

IF  PROV_ID  EQ  &&PROLD 

ON  TABLE  SAVE  AS  HOLD 

END 

-RUN 

-SET  &&RECTYPE= ' 9 ' ; 

DEFINE  FILE  VISIT  ADD 
RECTP/A1= ' &&RECTYPE  * ; 

PRONEW/A5= • &&PRNEW ' ; 

PAD/A34=' . •  ; 

END 

-RUN 

-TYPE  RECORDS  TYPE  9  BEING  PROCESSED 
FILEDEF  HOLD  DISK  C:HOLD.FTM  APPEND 
TABLEF  FILE  VISIT. DISP 

PRINT  RECTP  CLINIC  VDATE  PRONEW  PTID  LITHO  DISP  PAD 

IF  PROV_ID  EQ  &&PROLD 

ON  TABLE  SAVE  AS  HOLD 

END 

-RUN 
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_* - - - - - * 

-*  * 

-*  PROCEDURE  RXXF200.FEX  PREPARED  BY  J.J.S  * 

-*  ON  06/04/84  * 

-*  LOADS  THE  PATIENT  DATA  BASE  * 

-*  DATA  IS  IN  FILE  ' PATIENT . OUT  *  * 

-*  29  OCT  86  CHANGE  INPUT  FILE  TO  E  DRIVE  D  BOLLING  * 

_* - - - * 


SET  PRINT=OFFLINE 

FILEDEF  RXXF200  DISK  E : PATIENT . OUT 
FILEDEF  PATLOG  DISK  PATIENT.LOG 
USE 

D; PATIENT. FOC 
END 

-CRTCLEAR 

MODIFY  FILE  PATIENT 
LOG  DUPL  MSG  OFF 
LOG  NOMATCH  MSG  OFF 

TYPE  AT  START  "PATIENT  LOAD  PROCEDURE  IN  PROGRESS" 

COMPUTE 

RECTYPE/A3  =; 

FIXFORM  RECTYPE/A3 

FIXFORM  PTID/Cll  PTDOB/C6  CATEG/A3 
FIXFORM  PTLITHO/C8 

FIXFORM  REGDATE/C6  SEX/Cl  RACE/Cl  PREFIX/C2  PAYGRADE/C2 
FIXFORM  JOBCODE/C4  PTLOC/C6  TRAINEE/Cl  VA/Cl  HCI/Cl 
FIXFORM  ZIP/C5  PTDUALSSN/C9  PTFORGN/C3 
iL*  IF  RECTYPE  EQ  *XXX'  GOTO  TOP; 

IF  RECTYPE  EQ  *200'  GOTO  LOADER; 

TYPE  ON  PATLOG  "UNRECOGNIZED  RECORD  TYPE  <RECTYPE  FOR  PATIENT  <PTID" 
CASE  LOADER 
MATCH  PTID 

ON  NOMATCH  INCLUDE 
ON  MATCH  GOTO  SEG2 
ENDCASE 
-* 

CASE  SEG2 
MATCH  PTLITHO 

ON  NOMATCH  TYPE  ON  PATLOG 

"PATIENT  <PTID  ON  FILE  . .  NO  MATCH  FOR  LITHO  <PTLITHO" 

ON  NOMATCH  TYPE  ON  PATLOG 

"  ...  <D. PTLITHO" 

ON  NOMATCH  REJECT 

ON  MATCH  UPDATE  CATEG  REGDATE  SEX  RACE  PREFIX  PAYGRADE 

ON  MATCH  UPDATE  JOBCODE  PTLOC  TRAINEE  VA  HCI  ZIP  PTDUALSSN  PTFO 

ENDCASE 
CHECK  OFF 
DATA  ON  RXXF200 
END 
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-* 

-*  PROCEDURE  RXXF300.FEX 

-*  LOADS  THE  PROVIDER  DATA  BASE 
-*  DATA  IS  IN  FILE  • PPROVIDER.OUT ' 

-*  29  OCT  86  CHANGE  INPUT  FILE  TO  E  DRIVE 
- - - 

FILEDEF  RXXF300  DISK  E: PROVIDER. OUT 
FILEDEF  PROVIDLG  DISK  PROVIDER.LOG 
USE 

D: PROVIDER. FOC 
END 

-CRTCLEAR 

MODIFY  FILE  PROVIDER 
LOG  DUPL  MSG  OFF 
LOG  NOMATCH  MSG  OFF 
TYPE  AT  START  "PROVIDER  LOAD  PROCEDURE  IN  PROGRESS" 

COMPUTE 

RECTYPE/A3  =; 

COMPUTE 
TOR/Al  =; 

FIXFORM  RECTYPE/A3  TOR/Al 

FIXFORM  PROVID/5  PROVDATE/6  PRCATEG/2 

FIXFORM  PRFNME/13  PRLNME/16  PRINIT/1 

FIXFORM  PRSSN/9  PRSTAT/1  PRPOS/2 

FIXFORM  PRPAYGR/2  PRJCODE/7  PRLTH/8  | 

IF  RECTYPE  EQ  'XXX'  GOTO  TOP; 

IF  RECTYPE  EQ  '300'  GOTO  LOADER; 

TYPE  "UNRECOGNIZED  RECORD  <RECTYPE  FOR  PROVIDER  <PROVID" 

CASE  LOADER 

IF  TOR  EQ  '!'  GOTO  ADDl ; 

IF  TOR  EQ  '2'  GOTO  CHANGE 1; 

IF  TOR  EQ  '3'  GOTO  DELETEl; 

TYPE  "UNRECOGNIZED  RECORD  TYPE  <TOR  FOR  PROVIDER  <PROVID" 

ENDCASE 

CASE  ADDl 
MATCH  PROVID 

ON  NOMATCH  INCLUDE 
ON  MATCH  TYPE  ON  PROVIDLG 

"PROVIDER  <PROVID  ON  FILE  . . .  CORRECT  AND  RESUBMIT 
"  LITHO  #  =  <PRLTH" 

•I  _ _ _ — 

ON  MATCH  REJECT 
ENDCASE 
CASE  CHANGE 1 
MATCH  PROVID 

ON  MATCH  UPDATE  PROVDATE  PRLNME  PRFNME  PRINIT  PRSTAT  PRCATEG 
ON  MATCH  UPDATE  PRPOS  PRPAYGR  PRJCODE  PRSSN  PRLTH 
ON  NOMATCH  TYPE  ON  PROVIDLG 

"PROVIDER  < PROVID  CHANGE  REJECTED...  CORRECT  AND  R 
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"  LITHO  #  =  <PRLTH" 

n  _ _ _ _ _ 

ON  NOMATCH  REJECT 
ENDCASE 
CASE  DELETE 1 
MATCH  PROVID 

ON  MATCH  TYPE  ON  PROVIDLG 

"PRVIDER  <PROVID  DELETED.  FOLLOWING  WAS  FILE  CONTENT 
"  <D.PROVDATE  <D.PRCATEG  <D.PRLNME  <D.PRFNME  <D.PRI 
"  <D.PRSSN  <D.PRSTAT  <D.PRPOS  <D.PRPAYGR  <PRJCODE" 

"  LITHO  =  <D.PRLTH" 

ON  MATCH  DELETE 

ON  NOMATCH  TYPE  ON  PROVIDLG 

"PROVIDER  <PROVID  DELETE  REJECTED.  CORRECT  AND  RES 
"  LITHO  #  =  <PRLTH" 

H_ _ _ _ _ _ _ _ 

ON  NOMATCH  REJECT 
ENDCASE 
CHECK  OFF 
DATA  ON  RXXF300 
END 
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-* - * 

-*  * 

-♦PROCEDURE  RXXF400.FEX  PREPARED  BY:  D.R. BOLLING  * 

-*  ON:  05/04/87  * 

-♦LOADS  THE  VISIT  DATA  BASE  ,  ALL  SEGMENTS  ♦ 

-*  * 

-* - * 

-* 


FILEDEF  RXXF400  DISK  D: VISIT. OUT 
FILEDEF  VISITLG  DISK  C: VISIT. LOG 
-START 

DOS  STATE  E : VISIT. FOC 
-RUN 

-IF  &RETCODE  NE  0  GOTO  UNEW  ; 

USE  E: VISIT. FOC 
END 

-GOTO  CONT 
-UNEW 

USE  E: VISIT. FOC  NEW 
END 

CREATE  FILE  VISIT 
-CONT 
-CRTCLEAR 
MODIFY  FILE  VISIT 


LOG  DUPL  MSG  OFF 
LOG  NOMATCH  MSG  OFF 

TYPE  AT  START  ON  VISITLG  "ENCOUNTER  LOAD  PROCEDURE  ERROR  LOG 
September  10,  1988  " 

TYPE  AT  START  "ENCOUNTER  LOAD  PROCEDURE  IN  PROGRESS  September  10, 

CHECK  OFF 

COMPUTE 

RECTYPE/Al  =; 

TIME2/I3=0  i 
REFERAL/A4= ' 

PR0F/A1= •  '  I 
INJ/A1= '  '  i 
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VISIT_CNT/I1=0 
PR0V2RES/A1='  ' 

' ;  J0BREL/A1= ’ 
NAVAIL/A1='  ' 
PURP/A1= '  ' 


TIME1/I3=0 
APPSTAT/A1= ' 
'  ;  DUTY/A1= ' 
ADMIT/A1 = '  ' 
RULE/A1= ' 


PROV2/A5= ' 
PLACE/A1= ' 
QTR/A1= ' 
ILLN/A1=' 
DX1C0DE/A5= 


—  ( 


FIXFORM  FNUM/A2  XI  RECTYPE/Al  CLINIC/C4  VDATE/C6  PROV1/C5  PTID/Cll 
FIXFORM  LITHO/C8 

— A————— . 


-♦  RECORD  VALIDATION 

-* - 

IF  FNUM  GT  '96'  GOTO  TOP; 

IF  FNUM  LT  '40'  GOTO  TOP; 

IF  RECTYPE  GT  'A'  GOTO  TOP; 

IF  RECTYPE  LT  '1'  GOTO  TOP; 

-* - 


LOAD  OF  THE  VISIT  KEY  DATA  FOR  ALL  FORMS. 


MATCH  CLINIC 

ON  MATCH  CONTINUE 
ON  NOMATCH  INCLUDE 
ON  NOMATCH  GOTO  TESTRECT 
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HATCH  VDATE 

ON  MATCH  CONTINUE 
ON  NOMATCH  INCLUDE 
ON  NOMATCH  GOTO  TESTRECT 
MATCH  PROVl 

ON  MATCH  CONTINUE 
ON  NOMATCH  INCLUDE 
ON  NOMATCH  GOTO  TESTRECT 
MATCH  PTID 

ON  MATCH  CONTINUE 
ON  NOMATCH  INCLUDE 
ON  NOMATCH  GOTO  TESTRECT 
MATCH  LITHO 

ON  MATCH  GOTO  TESTRECT 
ON  NOMATCH  INCLUDE 
ON  NOMATCH  GOTO  TESTRECT 

-* 

CASE  TESTRECT 
COMPUTE 

CLINIC  =  CLINIC; 

VDATE  =  VDATE ; 
i'n< tv  I  i-ttiiv  1  , 

PTID  =  PTID; 

LITHO  =  LITHO ; 


FNUM  =  FNUM; 

IF 

RECTYPE 

EQ 

•1' 

GOTO 

PROCITP 

IF 

RECTYPE 

EQ 

•2' 

GOTO 

PROC2TP 

IF 

RECTYPE 

EQ 

131 

GOTO 

PROC3TP 

IF 

RECTYPE 

EQ 

141 

GOTO 

PROC4TP 

IF 

RECTYPE 

EQ 

•5' 

GOTO 

PROC5TP 

IF 

RECTYPE 

EQ 

•6' 

GOTO 

PROC6TP 

IF 

RECTYPE 

EQ 

171 

GOTO 

PROC7TP 

IF 

RECTYPE 

EQ 

•8' 

GOTO 

PROC8TP 

IF 

RECTYPE 

EQ 

igt 

GOTO 

PROC9TP 

IF 

RECTYPE 

EQ 

•A' 

GOTO 

PROCATP 

ENDCASE 

_* - 

-*  RECORD  TRANSACTION  TYPE  PROCESSING  BEGINS 

_* - 

CASE  PROCITP 
MATCH  CLINIC 

ON  MATCH  CONTINUE 
ON  NOMATCH  REJECT 
MATCH  VDATE 

ON  MATCH  CONTINUE 
ON  NOMATCH  REJECT 
MATCH  PROVl 

ON  MATCH  CONTINUE 
ON  NOMATCH  REJECT 
MATCH  PTID 

ON  MATCH  CONTINUE 
ON  NOMATCH  REJECT 
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-* 

MATCH  LITHO 
ON  MATCH 
FIXFORM  X-38  X40 
FIXFORM  VCNT/1 
FIXFORM  APPSTAT/1 
FIXFORM  QTR/1 
FIXFORM  INJ/1 
ON  MATCH  UPDATE 
MATCH  UPDATE 
MATCH  UPDATE 


TIMEl/3 
REFERAL/4 
PROF/1 
PURP/1 
VCNT  TIMEl 


PROV2/5 
PLACE/ 1 
NAVAIL/1 
RULE/1 
PROV2  TIME2 


TIME2/3 
JOBREL/1 
ADMIT/ 1 
DXlCODE/5 
PROV2RES  APPSTAT 


PROV2RES/1 

DUTY/1 

ILLN/1 


PLACE 


ON 
ON 
ON 
GOTO 
ENDCASE 

-* - 

-* 

-* - 


REFERAL  JOBREL  DUTY  QTR  PROF  NAVAIL  ADMIT  ILLN 
INJ  PURP  RULE  DXICODE 


NOMATCH 

TOP 


REJECT 


RECORD  TRANSACTION  TYPE  '2'  PROCESSING  BEGINS 


CASE  PROC2TP 
MATCH  CLINIC 

ON  MATCH  CONTINUE 
ON  NOMATCH  REJECT 
MATCH  VDATE 

ON  MATCH  CONTINUE 
ON  NOMATCH  REJECT 
MATCH  PROVl 

ON  MATCH  CONTINUE 
ON  NOMATCH  REJECT 
MATCH  PTID 

ON  MATCH  CONTINUE 
ON  NOMATCH  REJECT 
MATCH  LITHO 
ON  MATCH 

FIXFORM  X-38  X40  PRCODE/1  PCODE/5 
ON  MATCH  CONTINUE 
ON  NOMATCH  REJECT 
MATCH  PCODE 

ON  MATCH  REJECT 
ON  NOMATCH  INCLUDE 
GOTO  TOP 
ENDCASE 


-* 

—  It  —  —  — 

RECORD  TRANSACTION  TYPE  '3'  PROCESSING  BEGINS 

CASE 

PROC3TP 

MATCH 

CLINIC 

ON 

MATCH 

CONTINUE 

ON 

NOMATCH 

REJECT 

MATCH 

VDATE 

ON 

MATCH 

CONTINUE 

ON 

NOMATCH 

REJECT 

MATCH 

PROVl 

ON 

MATCH 

CONTINUE 
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ON  NOMATCH  REJECT 
MATCH  PTID 

ON  MATCH  CONTINUE 
ON  NOMATCH  REJECT 
MATCH  LITHO 
ON  MATCH 

FIXFORM  X-38  X40  SPCC/1 
ON  MATCH  COMPUTE 

ON  MATCH  CONTINUE 
ON  NOMATCH  REJECT 
MATCH  Spec 

ON  MATCH  REJECT 
ON  NOMATCH  INCLUDE 
GOTO  TOP 
ENDCASE 


RECORD  TRANSACTION  TYPE  '4*  PROCESSING  BEGINS 


CASE  PROC4TP 
MATCH  CLINIC 

ON  MATCH  CONTINUE 
ON  NOMATCH  REJECT 
MATCH  VDATE 

ON  MATCH  CONTINUE 
ON  NOMATCH  REJECT 
MATCH  PROVl 

ON  MATCH  CONTINUE 
ON  NOMATCH  REJECT 
MATCH  PTID 

ON  MATCH  CONTINUE 
ON  NOMATCH  REJECT 
MATCH  LITHO 
ON  MATCH 

FIXFORM  X-38  X40  OTHER/5 
ON  MATCH  CONTINUE 
ON  NOMATCH  REJECT 
MATCH  OTHER 

ON  MATCH  REJECT 
ON  NOMATCH  INCLUDE 
GOTO  TOP 
ENDCASE 


RECORD  TRANSACTION  TYPE  '5'  PROCESSING  BEGINS 


CASE  PROC5TP 
MATCH  CLINIC 

ON  MATCH  CONTINUE 
ON  NOMATCH  REJECT 
MATCH  VDATE 

ON  MATCH  CONTINUE 
ON  NOMATCH  REJECT 
I  MATCH  PROVl 
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ON  MATCH  CONTINUE 
ON  NOMATCH  REJECT 
MATCH  PTID 

ON  MATCH  CONTINUE 
ON  NOMATCH  REJECT 
MATCH  LITHO 
ON  MATCH 

FIXFORM  X-38  X40  UIC/6  TIMPRl/3  TIMPR2/3  TIMTRl/3  TIMTR2/3  MACT/3  OACT 
FIXFORM  RMIL/3  DEPD/3  CIVIL/3  CSHEET/1 
ON  MATCH  CONTINUE 
ON  NOMATCH  REJECT 
MATCH  UIC 

ON  MATCH  REJECT 

ON  NOMATCH  TYPE  "  <UIC  <CSHEET  '• 

ON  NOMATCH  INCLUDE 
GOTO  TOP 
ENDCASE 


RECORD  TRANSACTION  TYPE  '6'  PROCESSING  BEGINS 


CASE  PROC6TP 
MATCH  CLINIC 

ON  MATCH  CONTINUE 
ON  NOMATCH  REJECT 
MATCH  VDATE 

ON  MATCH  CONTINUE 
ON  NOMATCH  REJECT 
MATCH  PROVl 

ON  MATCH  CONTINUE 
ON  NOMATCH  REJECT 
MATCH  PTID 

ON  MATCH  CONTINUE 
ON  NOMATCH  REJECT 
MATCH  LITHO 
ON  MATCH 

FIXFORM  X-38  X40  SPROG/1 
ON  MATCH  CONTINUE 
ON  NOMATCH  REJECT 
MATCH  SPROG 

ON  MATCH  REJECT 
ON  NOMATCH  INCLUDE 
GOTO  TOP 
ENDCASE 


RECORD  TRANSACTION  TYPE  '7'  PROCESSING  BEGINS 


CASE  PROC7TP 
MATCH  CLINIC 

ON  MATCH  CONTINUE 
ON  NOMATCH  REJECT 
MATCH  VDATE 

ON  MATCH  CONTINUE 


J 


J 


I 
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ON  NONATCH  REJECT 
(  MATCH  PROVl 

ON  MATCH  CONTINUE 
ON  NOMATCH  REJECT 
MATCH  PTID 

ON  MATCH  CONTINUE 
ON  NOMATCH  REJECT 
MATCH  LITHO 
ON  MATCH 

FIXFORM  X-38  X40  DX2CODE/5 
ON  MATCH  CONTINUE 
ON  NOMATCH  REJECT 
MATCH  DX2CODE 

ON  MATCH  REJECT 
ON  NOMATCH  INCLUDE 
GOTO  TOP 
ENDCASE 


-*  RECORD  TRANSACTION  TYPE  '8'  PROCESSING  BEGINS 


CASE  PROC8TP 
MATCH  CLINIC 

ON  MATCH  CONTINUE 
ON  NOMATCH  REJECT 
MATCH  VDATE 

ON  MATCH  CONTINUE 
ON  NOMATCH  REJECT 
I  •  MATCH  PROVl 

ON  MATCH  CONTINUE 
ON  NOMATCH  REJECT 
MATCH  PTID 

ON  MATCH  CONTINUE 
ON  NOMATCH  REJECT 
MATCH  LITHO 
ON  MATCH 

FIXFORM  X-38  X40  ASSESMNT/1 
ON  MATCH  CONTINUE 
ON  NOMATCH  REJECT 
MATCH  ASSESMNT 

ON  MATCH  REJECT 
ON  NOMATCH  INCLUDE 
GOTO  TOP 
ENDCASE 

_* - 

-*  RECORD  TRANSACTION  TYPE  '9'  PROCESSING  BEGINS 

- 

CASE  PROC9TP 
MATCH  CLINIC 

ON  MATCH  CONTINUE 
ON  NOMATCH  REJECT 
MATCH  VDATE 

ON  MATCH  CONTINUE 
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ON  NOMATCH  REJECT 
MATCH  PROVl 

ON  MATCH  CONTINUE 
ON  NOMATCH  REJECT 
MATCH  PTID 

ON  MATCH  CONTINUE 
ON  NOMATCH  REJECT 
MATCH  LITHO 
ON  MATCH 

FIXFORM  X-38  X40  DISP/2 
ON  MATCH  CONTINUE 
ON  NOMATCH  REJECT 
MATCH  DISP 

ON  MATCH  REJECT 
ON  NOMATCH  INCLUDE 
GOTO  TOP 
ENDCASE 


-*  RECORD  TRANSACTION  TYPE  'A*  PROCESSING  BEGINS 


CASE 

PROCATP 

MATCH  CLINIC 

ON 

MATCH 

CONTINUE 

ON 

NOMATCH 

REJECT 

MATCH  VDATE 

ON 

MATCH 

CONTINUE 

ON 

NOMATCH 

REJECT 

MATCH  PROVl 

ON 

MATCH 

CONTINUE 

ON 

NOMATCH 

REJECT 

MATCH  PTID 

ON 

MATCH 

CONTINUE 

ON 

NOMATCH 

REJECT 

MATCH  LITHO 

ON 

MATCH 

FIXFORM  X-38 

X40  GPATID/ 11 

ON 

MATCH 

CONTINUE 

ON 

NOMATCH 

REJECT 

MATCH  GPATID 

ON 

MATCH 

REJECT 

ON 

NOMATCH 

INCLUDE 

GOTO 

TOP 

ENDCASE 

- 

DATA  ON  RXXF400 
END 
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-*  RXXFCCL.FEX  D  R  BOLLING  03/18/86  * 

—  *  * 

-*  CONTROL  PROGRAM  TO  CORRECT  CLINIC  CODES  IN  VISIT  FILE  * 
-*  * 

-************************************************************* 
-SET  &4CLOLD='  •; 

-SET  St&CLNEW=  •  •  ; 

-SET  &&RTN='  •; 

-SET  &EMSG= '  • ; 

-SCR 

-CRTFORM  LINE  3 

CORRECT  CLINIC  CODE  IN  VISIT  FILE  ’* 

_ii  n 

-"ENTER  OLD  CLINIC  ID:  <. IRHWT. &&CLOLD>" 

_ii  11 

-"ENTER  NEW  CLINIC  ID:  <. IRHWT. &&CLNEW>" 

_ll  N 


_ll  N 

_ll  II 


X  TO  RETURN  TO  PREVIOUS  MENU" 

E  TO  CHANGE  OLD  CLINIC  CODE  TO  NEW  CLINIC  CODE" 
SELECT:  <.IRHW.&&RTN" 


■"HIT  ENTER  TO  CONTINUE" 

.11  II 
.11  II 


!•  -"  <.yELL.D.&EMSG>" 

-SET  &EMSG=' PLEASE  ENTER  DATA  FOR  ALL  FIELDS.*; 

-IF  &&RTN  EQ  'X*  THEN  GOTO  EXIT; 

-IF  &&CLOLD  EQ  '  '  THEN  GOTO  SCR; 

-IF  &&CLNEW  EQ  '  '  THEN  GOTO  SCR; 

-IF  &&RTN  NE  'E*  THEN  GOTO  SCR; 

-*  ENSURE  NO  CURRENT  HOLD  FILE 

DOS  STATE  C-.HOLD.FTM 

-RUN 

-IF  &RETCODE  NE  0  GOTO  EXRXX; 

DOS  ERASE  HOLD.FTM 

-EXRXX 
EX  RXXCCLD 
-RUN 

-*  DID  ANY  RECORDS  GET  CREATED? 

DOS  STATE  C: HOLD.FTM 
-RUN 

-IF  &RETCODE  EQ  0  GOTO  NEXPROG; 

-SET  &EMSG='NO  DATA  WAS  FOUND  WITH  THE  ABOVE  OLD  CLINIC  CODE. ' ; 
-GOTO  SCR 
-NEXPROG 
EX  RXXCORL 
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-RUN 

FILEDEF  DELE  DISK  ClHOLD.FTM 
-RUN 

-WRITE  DELE  &&CLOLD 
MODIFY  FILE  VISIT 
FIXFORM  CLINIC/4 
MATCH  CLINIC 

ON  MATCH  DELETE 
ON  NOMATCH  REJECT 
DATA  ON  DELE 
END 
-RUN 
-EXIT 
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-**********ii***1i*1t****1t**********1t**********1t***************** 

-*  RXXFCPA.FEX  D  R  BOLLING  03/18/86  * 

-*  * 

-*  CONTROL  PROGRAM  TO  CORRECT  PATIENT  CODES  IN  VISIT  FILE  * 
— *  * 

-It************  *************  *************  *******  ******  ********* 

-SET  &SSNOLD= »  ' ; 

-SET  iSSNNEW= '  ' ; 

-SET  «iFMPOLD=  •  '  ; 

-SET  &FMPNEW='  •; 

-SET  &&RTN=='  •; 

-SET  &EMSG= '  ' ; 

“SCR 

-CRTFORM  LINE  3 

CORRECT  PATIENT  CODE  IN  VISIT  FILE  •• 

_ii  II 


-•'ENTER  OLD  PATIENT  SSN:  < . IRHWT. &SSNOLD> 


FMP:  <. IRHWT. &FMPOLD>" 


-"ENTER  NEW  PATIENT  SSN:  <• IRHWT . &SSNNEW> 


FMP:  <. IRHWT. &FMPNEW>" 


X  TO  RETURN  TO  PREVIOUS  MENU" 

E  TO  CHANGE  OLD  PATIENT  CODE  TO  NEW  PATIENT  CODE" 
SELECT:  <.IRHW.&&RTN" 


-"HIT  ENTER  TO  CONTINUE" 


-"  <.YELL.D.&EMSG>" 

-SET  &EMSG= • PLEASE  ENTER  DATA  FOR  ALL  FIELDS.'; 
-IF  &&RTN  EQ  'X'  THEN  GOTO  EXIT; 

-IF  &SSNOLD  EQ  '  '  THEN  GOTO  SCR; 

-IF  &SSNNEW  EQ  '  '  THEN  GOTO  SCR; 

-SET  4FO='l'  &FMPOLD; 

-SET  &FN='l'  &FMPNEW; 

-IF  &FO  EQ  '1  '  THEN  GOTO  SCR; 

-IF  &FN  EQ  '1  '  THEN  GOTO  SCR; 

-IF  &&RTN  NE  'E'  THEN  GOTO  SCR; 

-SET  &&PAOLD=  &SSNOLD  &FMPOLD  ; 

-SET  &&PANEW=  &SSNNEW  &FMPNEW  ; 

-************************************ 

-*  ENSURE  NO  CURRENT  HOLD  FILE  * 

DOS  STATE  C:HOLD.FTM 
-RUN 

-IF  &RETCODE  NE  0  GOTO  EXRXX; 

DOS  ERASE  HOLD.FTM 

—************************************ 

-EXRXX 
EX  RXXCPAD 
-RUN 

-■************************************ 
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-*  DID  ANY  RECORDS  GET  CREATED?  * 

DOS  STATE  CtHOLD.FTM 
-RUN 

-IF  &RETCODE  EQ  0  GOTO  NEXPROG; 

-SET  &EMSG='NO  DATA  WAS  FOUND  WITH  THE  ABOVE  OLD  PATIENT  ID.' 
-GOTO  SCR 

-■k*1ftfit1fk**1t*************A*****1fk***** 

-NEXPROG 
EX  RXXCORL 
-RUN 

FILEDEF  HOLD  DISK  C:HOLD.FTM 
-RUN 

TABLE  FILE  VISIT. PATIENT_ID 

PRINT  CLINIC  VISIT_DATE  PROV_ID  PATIENT_ID 

IF  PATIENT_ID  EQ  &&PAOLD 

ON  TABLE  SAVE  AS  HOLD 

END 

-RUN 

FILEDEF  DELE  DISK  C:HOLD.FTM 
-RUN 

MODIFY  FILE  VISIT 

FIXFORM  CLINIC/4  VISIT_DATE/6  PROV_ID/5  PATIENT_ID/11 
MATCH  CLINIC 

ON  MATCH  CONTINUE 
ON  NOMATCH  REJECT 
MATCH  VISIT  DATE 
ON  MATCH  CONTINUE 
ON  NOMATCH  REJECT 
MATCH  PROV_ID 

ON  MATCH  CONTINUE 
ON  NOMATCH  REJECT 
MATCH  PATIENT_ID 
ON  MATCH  DELETE 
ON  NOMATCH  REJECT 
DATA  ON  DELE 
END 
-RUN 
-EXIT 
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^  * -IHHHticIt  it  trlHHtitlUt*  *  It  It  ithltiilfk  hit  *******  *********  *11**1111*11  It -k*  It  1c  *  It*  It  * 

-*  RXXFCPR.FEX  D  R  BOLLING  03/18/86  * 

-*  * 

-*  CONTROL  PROGRAM  TO  CORRECT  PROVIDER  CODES  IN  VISIT  FILE  * 
-*  * 

*************************************************************** 
-SET  &&PROLD=' 

-SET  &&PRNEW='  •; 

-SET  fi&RTN*»  •; 

-SET  &EMSG= •  • ; 

-SCR 

-CRTFORM  LINE  3 

CORRECT  PROVIDER  CODE  IN  VISIT  FILE  '• 

_ii  II 

-"ENTER  OLD  PROVIDER  ID:  < .  IRHWT.  fitStPROLD>" 

_ii  II 

-"ENTER  NEW  PROVIDER  ID:  <. IRHWT. &&PRNEW>" 

_ii  II 
_ii  II 

-"  X  TO  RETURN  TO  PREVIOUS  MENU" 

-"  E  TO  CHANGE  OLD  PROVIDER  CODE  TO  NEW  PROVIDER  CODE" 

-"  SELECT:  < . IRHW. &&RTN" 

_ii  II 

-"HIT  ENTER  TO  CONTINUE" 

_ii  II 
_ii  II 
_ii  II 

- "  < . YELL . D . &EMSG> " 

-SET  &EMSG= ' PLEASE  ENTER  DATA  FOR  ALL  FIELDS . ' ; 

-IF  &&RTN  EQ  ‘X*  THEN  GOTO  EXIT; 

-IF  &&PROLD  EQ  '  '  THEN  GOTO  SCR; 

-IF  &&PRNEW  EQ  '  '  THEN  GOTO  SCR; 

-IF  &&RTN  NE  'E'  THEN  GOTO  SCR; 
-********************************** 

-*  ENSURE  NO  CURRENT  HOLD  FILE  * 

DOS  STATE  C;HOLD.FTM 
-RUN 

-IF  &RETCODE  NE  0  GOTO  EXRXX; 

DOS  ERASE  HOLD.FTM 
—********************************** 

-EXRXX 
EX  RXXCPRD 
-RUN 

—********************************** 

-*  DID  ANY  RECORDS  GET  CREATED?  * 

DOS  STATE  C: HOLD.FTM 
-RUN 

-IF  &RETCODE  EQ  0  GOTO  NEXPROG; 

-SET  &EMSG=*NO  DATA  WAS  FOUND  WITH  THE  ABOVE  OLD  PROVIDER  CODE. 
-GOTO  SCR 

—*********************************** 

-NEXPROG 
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EX  RXXCORL 
-RUN 

FILEDEF  HOLD  DISK  C:HOLD.FTM 
-RUN 

TABLE  FILE  VISIT. PROV_ID 

PRINT  CLINIC  VISIT_DATE  PROV_ID 

IF  PROV_ID  EQ  &&PROLD 

ON  TABLE  SAVE  AS  HOLD 

END 

-RUN 

FILEDEF  DELE  DISK  C:HOLD.FTM 
-RUN 

MODIFY  FILE  VISIT 

FIXFORM  CLINIC/4  VISIT_DATE/6  PROV_ID/5 
MATCH  CLINIC 

ON  MATCH  CONTINUE 
ON  NOMATCH  REJECT 
MATCH  VISIT_DATE 

ON  MATCH  CONTINUE 
ON  NOMATCH  REJECT 
MATCH  PROV_ID 

ON  MATCH  DELETE 
ON  NOMATCH  REJECT 
DATA  ON  DELE 
END 
-RUN 
-EXIT 


2 


*  * 

*  RXXFDCL.FEX  DUMP  CLINIC. FOC  FOR  SHIPMENT  * 

*  * 

*  3/4/86  D  R  BOLLING  * 

*  CHANGE  DRIVE  FOR  SITE  TO  D  9/30/86  D  R  BOLLING  * 

*  CHANGE  DRIVE  FOR  SITE  TO  C  12/16/86  D  R  BOLLING  * 

*  PUTTING  SYSTEM  BACK  ON  C  * 

*************************************************************** 
CRTCLEAR 

SET  StSEL= '  •  ; 

MENU 

CRTFORM 


CLINIC  DATA 

PREPARE  BERNOULLI  CARTRIDGE  FOR  SHIPMENT  TO  FT.  DETRICK 

1.  PLACE  NEWLY  FORMATED  CARTRIDGE  IN  DRIVE  E. 

2.  DRIVE  D  SHOULD  CONTAIN  CLINIC. FOC  FILE  (STANDARD) 

X  . . .  RETURN  TO  PREVIOUS  MENU  C  . . .  CONTINUE 


ENTER  YOUR  SELECTION . <&SEL  <70  I" 


-IF  &SEL  EQ  X  GOTO  EXIT  ELSE  IF  &SEL  EQ  C  GOTO  CONTI 
-ELSE  GOTO  MENU; 

-CONTI 

-CRTCLEAR 

-TYPE 

-TYPE  PREPARATION  OF  FT.  DETRICK  BERNOULLI  CLINIC  FILE 
-TYPE 

-TYPE  IN  PROGRESS 

-TYPE 

USE  C: SITE. IDF 
END 

FILEDEF  SITEF  DISK  C: SITE. IDF 
-RUN 

-SET  &&SITE=' 

-READ  SITEF  &&SITE 
USE 


D: CLINIC. FOC 
E : DETCLIN . FTM  NEW 

END 

FILEDEF  DETR  DISK  E : DETCLIN . FTM 
-SET  ALL=ON; 

DEFINE  FILE  CLINIC 


1 


SITE/A4=‘&&SITE' ; 

END 

-RUN 

-TYPE  CLINIC  RECORDS  BEING  PROCESSED 

TABLEF  FILE  CLINIC 

PRINT  SITE  SEG. CLINIC 

ON  TABLE  SAVE  AS  DETR 

END 

-RUN 

-EXIT 


2 


-*************************************************************** 


-* 


* 


-*  RXXFDPA.FEX 


DUMP  PATIENT. FOC  FOR  SHIPMENT  * 

* 


-* 

ENCRYPT 

'  SSN 

CHANGE 

DRIVE 

CHANGE 

DRIVE 

FOR  SITE  TO  D 
BACK  TO  D 


3/4/86 

D 

R 

4/2/86 

D 

R 

9/30/86 

D 

R 

12/16/86 

D 

R 

BOLLING  * 
BOLLING  * 
BOLLING  * 
BOLLING  * 


-1c************************************************************** 


-CRTCLEAR 
-SET  &SEL= '  ' ; 

-MENU 

-CRTFORM 

-”  PATIENT  DATA 

-"  PREPARE  BERNOULLI  CARTRIDGE  FOR  SHIPMENT  TO  FT.  DETRICK 


1.  PLACE  NEWLY  FORMATED  CARTRIDGE  IN  DRIVE  E. 

2.  DRIVE  D  SHOULD  CONTAIN  PATIENT. FOC  FILE  (STANDARD). 

X  . . .  RETURN  TO  PREVIOUS  MENU  C  . . .  CONTINUE 


ENTER  YOUR  SELECTION . <&SEL  <70  | '• 


-IF  &SEL  EQ  X  GOTO  EXIT  ELSE  IF  &SEL  EQ  C  GOTO  CONTI 
-ELSE  GOTO  MENU; 

-CONTI 

I  -CRTCLEAR 

-TYPE 

-TYPE  PREPARATION  OF  FT.  DETRICK  BERNOULLI  PATIENT  FILE 
-TYPE 

-TYPE  IN  PROGRESS 

-TYPE 

USE  E; SITE. IDF 
END 

FILEDEF  SITEF  DISK  E: SITE. IDF 
-RUN 

-SET  &&SITE=' 

-READ  SITEF  &&SITE 
USE 

D: PATIENT. FOC 
E : DETPATI . FTM  NEW 

END 

FILEDEF  DETR  DISK  E ; DETPATI . FTM 
-SET  ALL=ON; 

DEFINE  FILE  PATIENT 


1 


SITE/A4= • &&SITE ' ; 

FMP/A2=  EDIT(PTID, '$$$$$$$$$99') ; 
C1/A1=  EDIT(PTID, '9$$$$$$$$$$') ; 
C2/A1=  EDIT(PTID, ' $9$$$$$$$$$ • )  ; 
C3/A1=  EDIT(PTID, '$$9$$$$$$$$') ; 
C4/A1=  EDIT(PTID, '$$$9$$$$$$$') ; 
C5/A1=  EDIT(PTID, '$$$$9$$$$$$')  ; 
C6/A1=  EDIT(PTID, •$$$$$9$$$$$') ; 
C7/A1=  EDIT(PTID, '$$$$$$9$$$$') ; 
C8/A1=  EDIT(PTID, '$$$$$$$9$$$')  ; 
C9/A1=  EDIT(PTID, '$$$$$$$$9$$' ) ; 


H1/A1=DEC0DE  Cl(l 

9  '3'  0  '6') 

4* 

2 

•O' 

3 

•8' 

4 

•1» 

5 

•7' 

6 

•9' 

7 

•5' 

8 

•2' 

H2/A1=DEC0DE  C2(l 

9  '3'  0  *6') 

4  ' 

2 

•O' 

3 

•8* 

4 

'!• 

5 

•  7  • 

6 

•9' 

7 

•  51 

8 

•2' 

H3/A1=DEC0DE  C3(l 

9  '3*  0  '6') 

4' 

2 

'O' 

3 

•8' 

4 

•1* 

5 

•7' 

6 

•  91 

7 

•5' 

8 

•2' 

H4/A1=DEC0DE  C4(l 

9  '3'  0  '6') 

4  • 

2 

•O' 

3 

•8  • 

4 

•I* 

5 

•  71 

6 

•9' 

7 

•5' 

8 

•2' 

H5/A1=DEC0DE  C5(l 

9  '3'  0  '6') 

4' 

2 

•O' 

3 

•8* 

4 

•1' 

5 

•7' 

6 

•9' 

7 

•5' 

8 

•2' 

H6/A1=DEC0DE  C6(l 

9  '3*  0  *6') 

4' 

2 

•O' 

3 

•8* 

4 

•1* 

5 

•7' 

6 

•9' 

7 

151 

8 

•2' 

H7/A1=DEC0DE  C7(l 

9  '3'  0  *6') 

4' 

2 

•O' 

3 

•8* 

4 

•1' 

5 

•7  ' 

6 

•  91 

7 

•5' 

8 

•2' 

H8/A1=DEC0DE  C8(l 

9  '3'  0  '6') 

4  ' 

2 

•O' 

3 

•8' 

4 

•1' 

5 

•7' 

6 

•9» 

7 

•5' 

8 

•2' 

- - 

H9/A1=DEC0DE  C9(l 

9  '3'  0  '6') 

4' 

2 

•O' 

3 

•8' 

4 

•!• 

5 

•  7  • 

6 

•  91 

7 

•5' 

8 

•2' 

NSSN/A9=H6 | H8 | HI | H5 | H2 | H9 | H4 | H7 | H3 ; 
C1/A1=  EDIT(PT_DUAL_SSN, '9$$$$$$$$')  ; 
C2/A1=  EDIT(PT_DUAL_SSN, '$9$$$$$$$‘); 
C3/A1=  EDIT(PT_DUAL_SSN, '$$9$$$$$$') ; 
C4/A1=  EDIT(PT_DUAL_SSN, '$$$9$$$$$') ; 
C5/A1=  EDIT(PT_DUAL_SSN, ' $$$$9$$$$ ' ) ; 
C6/A1=  EDIT(PT_DUAL_SSN, '$$$$$9$$$') ; 
C7/A1=  EDIT(PT_DUAL_SSN, '$$$$$$9$$') ; 
C8/A1=  EDIT(PT_DUAL_SSN, '$$$$$$$9$') ; 
C9/A1=  EDIT(PT_DUAL_SSN, '$$$$$$$$9') ; 


H1/A1=DEC0DE  Cl(l  '4' 

2 

•O' 

3 

•8' 

4 

•1' 

5 

•7' 

6 

•9' 

7 

•5' 

8 

•2' 

9  '  3  •  0  '  6  ' )  ; 
H2/A1=DEC0DE  C2(l  '4' 

2 

•O' 

3 

•8' 

4 

•1' 

5 

.71 

6 

•9' 

7 

•5' 

8 

•2' 

9  •  3  '  0  •  6  ' )  ; 
H3/A1=DEC0DE  C3(l  '4' 

2 

•O' 

3 

•8' 

4 

•1' 

5 

.71 

6 

•9' 

7 

•5' 

8 

•2' 

9  •  3  '  0  •  6  • )  ; 
H4/A1=DEC0DE  C4(l  '4' 

2 

•O' 

3 

•8' 

4 

'1' 

5 

17. 

6 

•9' 

7 

•5' 

8 

•2' 

9  •  3  '  0  '  6  ' )  ; 
H5/A1=DEC0DE  C5(l  '4' 

2 

•O' 

3 

•8' 

4 

•1' 

5 

•7  ' 

6 

•9' 

7 

•5' 

8 

•2' 

9  '  3  '  0  •  6  • )  ; 
H6/A1=DEC0DE  C6 ( 1  '4' 

2 

•O' 

3 

•8' 

4 

•1' 

5 

171 

6 

191 

7 

•5' 

8 

•2' 

9  '  3  '  0  '  6  '  )  ; 
H7/A1=DEC0DE  C7(l  '4' 

2 

•O' 

3 

•8' 

4 

•1' 

5 

•7' 

6 

•  91 

7 

•5' 

8 

•2' 

2 


9  •  3  •  0  '  6 ' )  ; 

H8/A1=DEC0DE  C8(l  *4'  2  ‘O'  3  '8'  4  5  '7*  6  '9'  7 

9  •  3  '  0  '  6 ' )  ; 

H9/A1=DEC0DE  C9(l  '4'  2  'O'  3  *8'  4  '!'  5  '7'  6  '9'  7 
9  '  3  '  0  '  6  ' )  ; 

DSSN/A9=H6 | H8 | HI | H5 | H2 | H9 | H4 | H7 | H3 ; 

END 


'5'  8  '2' 
'5'  8  '2' 


-RUN 

-TYPE  PATIENT  RECORDS  BEING  PROCESSED 
TABLEF  FILE  PATIENT 

PRINT  SITE  NSSN  FMP  PT_DOB  PT_CATEGORY  PT_LITHO  PT_REGDATE 

PT_GENDER  PT_RACE  PT_PREFIX  PT_PAY_GRADE  PT_JOB_CODE  PT_LOCATION 
PT_TRN_TDY  PT_VAELIG  PT_HCI  PT_ZIP_CODE  DSSN  PT_FOREIGN 
ON  TABLE  SAVE  AS  DETR 
END 


-RUN 


-EXIT 
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-*  * 

-*  RXXFDPR.FEX  DUMP  PROVIDER. FOC  FOR  SHIPMENT  * 

-*  * 

-*  3/4/86  D  R  BOLLING  * 

-*  REMOVE  NAME  AND  SSN  4/2/86  D  R  BOLLING  * 

-*  CHANGE  DRIVE  FOR  SITE  TO  D  9/30/86  D  R  BOLLING  * 

-*  CHANGE  DRIVE  BACK  TO  D  12/16/86  D  R  BOLLING  * 


-CRTCLEAR 
-SET  &SEL= •  • ; 
-MENU 
-CRTFORM 


PROVIDER  DATA 

PREPARE  BERNOULLI  CARTRIDGE  FOR  SHIPMENT  TO  FT.  DETRICK 

1.  PLACE  NEWLY  FORMATED  CARTRIDGE  IN  DRIVE  E. 

2.  DRIVE  D  SHOULD  CONTAIN  PROVIDER. FOC  FILE  (STANDARD). 

X  . . .  RETURN  TO  PREVIOUS  MENU  C  . . .  CONTINUE 


ENTER  YOUR  SELECTION . <&SEL  <70  |" 


-IF  &SEL  EQ  X  GOTO  EXIT  ELSE  IF  &SEL  EQ  C  GOTO  CONTI 
-ELSE  GOTO  MENU; 

-CONTI 

-CRTCLEAR 

-TYPE 

-TYPE  PREPARATION  OF  FT.  DETRICK  BERNOULLI  PROVIDER  FILE 
-TYPE 

-TYPE  IN  PROGRESS 

-TYPE 

USE  C: SITE. IDF 
END 

FILEDEF  SITEF  DISK  CrSITE.IDF 
-RUN 

-SET  &&SITE=' 

-READ  SITEF  &&SITE 
USE 

D; PROVIDER. FOC 
ErDETPROV.FTM  NEW 

END 

FILEDEF  DETR  DISK  ErDETPROV.FTM 
-SET  ALL=ON; 

DEFINE  FILE  PROVIDER 


1 


SITE/A4='fit&SITE'  ; 

END 

-RUN 

-TYPE  PROVIDER  RECORDS  BEING  PROCESSED 
TABLEF  FILE  PROVIDER 

PRINT  SITE  PROV_ID  PROV_DATE  PROV_STAT  PROV_CATEG  PROVPRPOS  PROV_PAYG 
PROV_JOBCODE  PROV_LITHO 
ON  TABLE  SAVE  AS  DETR 
END 
-RUN 
-EXIT 


(• 


2 


^  it  it  h  It  It  it  it  It  it  It  It  it  It  ii  it  "k  1c  it  it  It  It  it  It  It  *  It  it  “k  It  it  It  it -k  It  it -k  It  it  It  "k  it  1c  it  1c  if  It  It  it  it  it  It  it  ii  It  it  It  it  It  ic  It  it  it  if 
—  A  k 


-*  RXXFDVI.FEX  DUMP  VISIT. FOC  FOR  SHIPMENT  * 

-*  5/4/87  D  R  BOLLING  * 

-*  * 

-*  THIS  PROGRAM  ENCRYPTS  SSN  AND  DUMPS  DATA  TO  D  DRIVE  * 

—  A**4t4t:fc*****A4t*4tit4i4t*4t4tA*ilt4c*4titit*ik*4r****4r*****4t4t*****4r4t**4t4t**iiA*4t* 

-RUN 

-CRTCLEAR 
-SET  &SEL= '  • ; 

-MENU 

-CRTFORM 


VISIT  DATA 

PREPARE  BERNOULLI  CARTRIDGE  FOR  SHIPMENT  TO  FT.  DETRICK 

1.  PLACE  NEWLY  FORMATED  CARTRIDGE  IN  DRIVE  D. 

2.  VISIT. FOC  FILE  IN  DRIVE  E  WILL  BE  DUMPED  TO  D. 

X  . . .  RETURN  TO  PREVIOUS  MENU  C  . . .  CONTINUE 


ENTER  YOUR  SELECTION . <&SEL  <70  I”  • 


-IF  &SEL  EQ  X  GOTO  EXIT  ELSE  IF  &SEL  EQ  C  GOTO  CONTI 
-ELSE  GOTO  MENU; 

-CONTI 

-CRTCLEAR 

-TYPE 

-TYPE  PREPARATION  OF  FT.  DETRICK  BERNOULLI 

-TYPE 

-TYPE  IN  PROGRESS 

-TYPE 

USE  C: SITE. IDF 
END 

FILEDEF  SITEF  DISK  C; SITE. IDF 
-RUN 

-SET  &&SITE='  *; 

-READ  SITEF  &&SITE 
USE 

E; VISIT. FOC 
D: DETRICK. FTM  NEW 

END 

FILEDEF  DETR  DISK  D: DETRICK. FTM 
-SET  ALL=ON; 

-SET  &&RECTYPE= ' 1 ' ; 

DEFINE  FILE  VISIT 


1 


SITE/A4« • &&SITE ' ; 

RECTP/A1= • &&RECTYPE ' ; 

FMP/A2=  EDIT(PTID,'$$$$$$$$$99'); 
SSNUM/A9=EDIT(PATIENT_ID, *999999999$$') ; 
NUMT/I9=EDIT(SSNUM) ; 

K1/I2-NUMT/33554432 ; 
NUMT/I9=NUMT“K1*33554432 ; 
K2/I2=NUMT/1048576 ; 
NUMT/I9=NUMT-K2*1048576 ; 

K3/I2=NUMT/32768 ; 

NUMT/I9=NUMT-K3*32768 ; 

K4/I2=NUMT/1024; 

NUMT/I9=NUMT-K4*1024 ; 

K5/I2=NUMT/32; 

NUMT/I9=NUMT-K5*32 ; 

K6/I2=NUMT; 


KD1/A1=DEC0DE  K1,(0  'A* 

1 

'B'  2  'C  3 

'D' 

4 

•E' 

5  *F'  6  'G' 

7 

•H* 

8 

•I' 

9  'J*  10  'K*  11 

'L' 

12  'M*  13 

'N' 

14 

'O' 

15  'P'  16  ' 

Q' 

17 

•R' 

18  'S'  19  'T*  20 

'U 

'  21  'V  22 

'2* 

23 

'3 

'  24  '4*  25 

'5' 

26 

•6 

27  '7*  28  '8*  29 

•9 

'  30  '0*  31 

*1' 

)  ; 

KD2/A1=DEC0DE  K2(0  'A* 

1 

'B'  2  'C  3 

'D' 

4 

•E' 

5  'F'  6  'G' 

7 

•H' 

8 

•I' 

9  'J*  10  'K*  11 

•L' 

12  'M*  13 

'N* 

14 

'O' 

15  'P'  16  ' 

Q' 

17 

'R' 

18  'S'  19  'T*  20 

'U 

'  21  'V  22 

'2' 

23 

•3 

'  24  '4'  25 

•5' 

26 

'6 

27  *7*  28  *8*  29 

'9 

'  30  *0'  31 

*1' 

)  ; 

KD3/A1=DEC0DE  K3(0  'A* 

1 

•B'  2  *C'  3 

*D' 

4 

•E' 

5  *F'  6  *G' 

7 

•H' 

8 

'I' 

9  'J*  10  'K*  11 

'L' 

12  'M'  13 

'N' 

14 

*0' 

15  'P'  16  ' 

Q' 

17 

•R' 

18  'S'  19  'T*  20 

'U 

'  21  'V  22 

'2  ' 

23 

'3 

'  24  '4*  25 

'5» 

26 

•6 

27  '7*  28  *8*  29 

*9 

*  30  'O'  31 

*1' 

); 

KD4/A1«DEC0DE  K4(0  'A* 

1 

'B'  2  *C'  3 

'D' 

4 

'E* 

5  'F'  6  *G* 

7 

'H* 

8 

'I' 

9  'J*  10  *K'  11 

•L' 

12  'M*  13 

*N' 

14 

'O' 

15  'P*  16  ' 

Q' 

17 

'R* 

18  'S'  19  *T'  20 

•u 

'  21  'V  22 

'2' 

23 

*3 

'  24  *4*  25 

*5* 

26 

•6 

27  '7'  28  '8'  29 

'9 

'  30  'O'  31 

); 

KD5/A1=DEC0DE  K5(0*  'A' 

1 

'B'  2*  'C  3 

'D' 

4 

•E' 

5  'F'  6  'G' 

7 

'H' 

8 

'I' 

9  'J'  10  'K'  11. 

'L' 

12  *M'  13 

'N* 

14 

^0* 

15  'P'  16  ' 

Q' 

17 

'R' 

18  'S'  19  'T'  .20 

'U 

'  21  *V'  22 

'2' 

23 

'3 

'.24  '4'’25 

•5' 

26 

•6 

27  '7'  28  '8'  29 

'9 

'  30  'O'  31 

*1' 

); 

KD6/A1=DEC0DE  K6(0-  'A' 

1 

'B'  2  'C*  3 

'D' 

4 

•E' 

5  'F'  6  'G' 

7 

•H' 

8 

'I' 

9  'J'  10  'K'  11 

•L' 

•12  'M'  13  ' 

'N' 

14 

•O' 

15  'P'  16  ' 

Q' 

17 

'R* 

18  »'S'  19  'T'  20 

'U 

•  21  'V  22 

'2  ' 

23 

'3 

’  24  '4'  25 

'5' 

26 

•6 

27  '7'  28  '8'  29 

•9 

*  30  'O'  31 

« 

X; 

NSSN/A6=KD1 1  KD2  |  KD3  |  KD4  \  KD5  f-KD6  ; 

END 

-RUN 

-TYPE  RECORDS  TYPE  1  BEING  PROCESSED 
TABLEF  FILE  VISIT. TIMEl 

PRINT  SITE  RECTP  CLINIC  VDATE  PROVl  NSSN  FMP  SEG.LITHO 

ON  TABLE  SAVE  AS  DETR 

END 

-RUN 

FILEDEF  DETR  DISK  D; DETRICK. FTM  APPEND 
-SET  &&RECTYPE= ' 2 ' ; 

DEFINE  FILE  VISIT  ADD 


2 


RECTP/A1= • &&RECTYPE • ; 

END 

-RUN 

-TYPE  RECORDS  TYPE  2  BEING  PROCESSED 
TABLEF  FILE  VISIT. PCODE 

PRINT  SITE  RECTP  CLINIC  VDATE  PROVl  NSSN  FMP  LITHO  FNUM  SEG. PCODE 

ON  TABLE  SAVE  AS  DETR 

END 

-RUN 

-SET  &SrRECTYPE= '  3  •  ; 

DEFINE  FILE  VISIT  ADD 
RECTP/A1= • 4&RECTYPE ' ; 

END 

-RUN 

-TYPE  RECORDS  TYPE  3  BEING  PROCESSED 
TABLEF  FILE  VISIT. SPCC 

PRINT  SITE  RECTP  CLINIC  VDATE  PROVl  NSSN  FMP  LITHO  FNUM  SPCC 

ON  TABLE  SAVE  AS  DETR 

END 

-RUN 

-SET  &&RECTYPE= ' 4 ' ; 

DEFINE  FILE  VISIT  ADD 
RECTP/ Al= •  fit&RECTYPE ' ; 

END 

-RUN 

-TYPE  RECORDS  TYPE  4  BEING  PROCESSED 
TABLEF  FILE  VISIT, OTHER 

PRINT  SITE  RECTP  CLINIC  VDATE  PROVl  NSSN  FMP  LITHO  FNUM  OTHER 

ON  TABLE  SAVE  AS  DETR 

END 

-RUN 

-SET  &&RECTYPE='5' ; 

DEFINE  FILE  VISIT  ADD 
RECTP/ Al= • &&RECTYPE ' ; 

END 

-RUN 

-TYPE  RECORDS  TYPE  5  BEING  PROCESSED 
TABLEF  FILE  VISIT. UIC 

PRINT  SITE  RECTP  CLINIC  VDATE  PROVl  NSSN  FMP  LITHO  FNUM  SEG. UIC 

ON  TABLE  SAVE  AS  DETR 

END 

-RUN 

-SET  fii&RECTYPE= '  6  •  ; 

DEFINE  FILE  VISIT  ADD 
RECTP/A1= ' &&RECTYPE ' ; 

END 

-RUN 

-TYPE  RECORDS  TYPE  6  BEING  PROCESSED 
TABLEF  FILE  VISIT. SPROG 

PRINT  SITE  RECTP  CLINIC  VDATE  PROVl  NSSN  FMP  LITHO  FNUM  SPROG 

ON  TABLE  SAVE  AS  DETR 

END 


3 


-RUN 

-SET  &«iRECTYPE= '  7  •  ; 

DEFINE  FILE  VISIT  ADD 
RECTP/A1= • &&RECTYPE ’ ; 

END 

-RUN 

-TYPE  RECORDS  TYPE  7  BEING  PROCESSED 
TABLEF  FILE  VISIT. DX2CODE 

PRINT  SITE  RECTP  CLINIC  VDATE  PROVl  NSSN  FMP  LITHO  FNUM  DIAG2_CODE 

ON  TABLE  SAVE  AS  DETR 

END 

-RUN 

-SET  &&RECTYPE= ' 8 ' ; 

DEFINE  FILE  VISIT  ADD 
RECTP/ Al= ' &&RECTYPE  * ; 

END 

-RUN 

-TYPE  RECORDS  TYPE  8  BEING  PROCESSED 
TABLEF  FILE  VISIT. ASSESMNT 

PRINT  SITE  RECTP  CLINIC  VDATE  PROVl  NSSN  FMP  LITHO  FNUM  ASSESMNT 

ON  TABLE  SAVE  AS  DETR 

END 

-RUN 

-SET  &&RECTYPE= ' 9 ' ; 

DEFINE  FILE  VISIT  ADD 
RECTP/A1= ' &&RECTYPE ' ; 

END 

(•  -RUN 

-TYPE  RECORDS  TYPE  9  BEING  PROCESSED 
TABLEF  FILE  VISIT. DISP 

PRINT  SITE  RECTP  CLINIC  VDATE  PROVl  NSSN  FMP  LITHO  FNUM  DISP 

ON  TABLE  SAVE  AS  DETR 

END 

-RUN 

-SET  &&RECTYPE='A* ; 

DEFINE  FILE  VISIT  ADD 
RECTP/ A 1= ' &&RECTYPE ' ; 

END 

-RUN 

-TYPE  RECORDS  TYPE  A  BEING  PROCESSED 
TABLEF  FILE  VISIT. GPATID 

PRINT  SITE  RECTP  CLINIC  VDATE  PROVl  NSSN  FMP  LITHO  FNUM  GPATID 

ON  TABLE  SAVE  AS  DETR 

END 

-RUN 

-CRTFORM 
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DUMP  IS  COMPLETE 


HIT  ENTER  TO  CONTINUE 


RUN 

EXIT 


5 


FII^=VISIT, SUFFIX=FOC, $ 

SEGNAME=VISLOC , SEGTyPE=Sl , $ 

FIELD=CLINIC , CL_UCA, A4 , $ 

SEGNAME-VISDTE , PARENT=VISLOC , SEGTYPE=S 1 , $ 
PIELD=VISIT_DATE, VDATE, I6YMD, $ 
SEGNAME=VISPROV, PARENT=VISDTE, SEGTYPE=S1 , $ 
FIELD=PROV_ID, PROVl , A5 , $ 

SEGNAME=VISITOR, PARENT=VISPROV, SEGTYPE=S1 , $ 
FIELD=PATIENT_ID , PTID , A1 1 , $ 

SEGNAME=LITHO, PARENT=VISITOR, SEGTYPE=S1 , $ 
FIELD=LITHO_CODE , LITHO , 18 , $ 
FIELD=FORM_NUM , FNUM , A2 , $ 

FIELD=VISIT_CNT , VCNT , I 1 , $ 

FIELD=PROVl_TIME , TIMEl , 13 , $ 
FIELD=PROVIDER_2 , PROV2 , A5 , $ 
FIELD=PROV2_TIME , TIME2 , 13 , $ 
FIELD=PROV2_RESON , PROV2RES , A1 , $ 
FIELD=APPT_STATUS , APPSTAT , A1 , $ 
FIELD=PLACE_OF_VIS , PLACE , A1 , $ 
FIELD=INP_REFERAL, REFERAL, A4 , $ 
FIELD=JOB_RELATED , JO BREL, A1 , $ 
FIELD=MIL_DUTY , DUTY , A1 , $ 

FIELD=MIL_QTR, QTR, A1 , $ 

FIELD=MIL_PROF , PROF , A1 , $ 

FIELD=NOT_AVAIL, NAVAIL, A1 , $ 
FIELD=ADMITTED , ADMIT , A1 , $ 

FIELD=INFIELD, ILLN, Al, $ 

FIELD=INJURIES , INJ , Al , $ 

FIELD=PURP_VIS , PURP, Al , $ 

FIELD=RO_F_UP , RULE , Al , $ 

FIELD=DIAGl_CODE , DXICODE , A5 , $ 
SEGNAME=V_PROC , PARENT=LITHO , SEGTYPE=S 1 , $ 
FIELD=PROC_CODE , PCODE , A5 , $ 

FIELD=PROV_CD , PRCODE , Al , $ 

SEGNAME=V_SPCC , PARENT=LITHO , SEGTYPE=S 1 , $ 
FIELD=SP_PRE_CODE , SPCC , Al , $ 
SEGNAME=V_OTHER, PARENT=LITHO, SEGTYPE=S1 , $ 
FIELD=OTHER_CODE , OTHER , A5 , $ 
SEGNAME=V_GROUP, PARENT=LITHO, SEGTYPE=S1 , $ 
FIELD=UNIT_ID, UIC , A6 , $ 

FIELD=TIME_PR1 , TIMPRl , 13 , $ 

FIELD=TIME_PR2 , TIMPR2 , 13 , $ 

FIELD=TIME_TR1 , TIMTRl , 13 , $ 

FIELD=TIME_TR2 , TIMTR2 , 13 , $ 
FIELD=NO_ACT_DUTY , MACT , 13 , $ 
FIELD=NO_OTH_DUTY , OACT , 13 , $ 
FIELD=NO_RET_MIL,RMIL, 13 , $ 
FIELD=NO_DEPEND, DEPD, 13 , $ 

FIELD=NO_CIVIL, CIVIL, 13 , $ 

FIELD=CONT_SHEET , CSHEET , Al , $ 


SEGNAME=V_SPEC , PARENT=LITHO , SEGTYPE=S 1 , $ 
FIELD=SPEC_PROG ,  SPRCX3 ,  A1 ,  $ 
SEGNAME=V_DIAG2 , PARENT=LITHO, SEGTYPE=S1 , $ 
FIELD=DIAG2_C0DE , DX2C0DE , A5 , $ 
SEGNAME=V_PSY , PARENT=LITHO , SEGTYPE=S1 , $ 
FIELD=ASSESMNT , ASSESMNT , A1 , $ 
SEGNAME=V_DISPOS , PARENT=LITHO , SEGTYPE=S 1 , $ 
FIELD=DISPOS , DISP , A2 , $ 

SEGNAME=V_GRSSN, PARENT=LITHO, SEGTYPE=S1 , $ 
FIELD=GR_PAT_ID, GPATID, All , $ 

END 

DBA=LUGNUT,$ 

USER=NUTMEG , ACCESS=RW , $ 
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APPENDIX  E 


MAINFRAME  FOCUS  LOAD  PROGRAMS  (REFERENCED  SECTION  6.2.3) 


I 

( 

i 

i 

•I 

I 
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APPENDIX  E 


CLINLOAD 

DIAGLOAD 

NLOAD 

OTHLOAD 

PASILO 

PATILOAD 

PATILD 

PROCLOAD 

PROVLOAD 

RXXF400 


MAINFRAME  FOCUS  LOAD  PROGRAMS 
TABLE  OF  CONTENTS 


Clinic  Description 
Diagnosis  Description 
New  Design  Visit  Data 
Other  Code  Description 
Patient  Sidpers 
Patient 
Patient  Deers 
Procedure  Description 
Provider 

Old  Design  Visit  Data 


-*  PROCEDURE  CLINLOAD.FEX  PREPARED  BY  D.R. BOLLING 

ON  01/10/86 

-*  LOADS  THE  CLINIC  FLAT  FILE  TO  FOCUS  FILE 
-*  (DETCLIN.DATA)  (CLINIC . FOCUS) 

TSO  ALLOC  F{CLINF)  DA (' DXB. POLK. CLINIC ' ) 

-CRTCLEAR 

MODIFY  FILE  CLINIC 

TYPE  AT  START  "CLINIC  LOAD  PROCEDURE  IN  PROGRESS" 

FIXFORM  CLINIC/8  CL_TITLE/20  CL_302CODE/2 
FIXFORM  CL_302LINE/I3 

MATCH  CLINIC 

ON  NOMATCH  INCLUDE 
ON  MATCH  CONTINUE 
CHECK  OFF 
DATA  ON  CLINF 
END 

TSO  FREE  F (CLINF) 


•  • 


- - 

-* 

-*  PROCEDURE  DIAGLOAD.FEX  PREPARED  BY  D.R. 

-*  ON  01/10/86 

-*  LOADS  THE  DIAGNOSIS  FLAT  FILE  TO  FOCUS  FILE 
-*  ( DETDIAG . DATA)  ( DIAGNOS . FOCUS ) 

- - 

TSO  ALLOC  F(DIAGF)  DA (DI AG. DECS 7. CODES)  SHR 

-CRTCLEAR 

MODIFY  FILE  NDIAG 

TYPE  AT  START  "DIAGNOSIS  LOAD  PROCEDURE  IN  PROGRESS" 
FIXFORM  DGNCD/5  X2  DGNDSC/50 

MATCH  DIAG_CODE 

ON  NOMATCH  INCLUDE 
ON  MATCH  UPDATE  DGNDSC 
CHECK  OFF 
DATA  ON  DIAGF 
END 


BOLLING 
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-* 


-* 


* 

* 


-♦PROCEDURE  NLOAD. 

-* 

-* 

-♦LOADS  THE  REDESIGNED  VISIT 


PREPARED  BY:  D.R.B.  ♦ 
ON:  06/03/87  ♦ 

* 

DATA  BASE  INTO  MAINFRAME  FOCUS 

* 


-* 

SET  BINS=64 

TSO  ALLOC  F (DETRICK)  DA (' DXB.U. REDS. JUL87 .VISIT ' ) 

-START 

-RUN 

-CRTCLEAR 
MODIFY  FILE  NCAMP 

TYPE  AT  START  "ENCOUNTER  LOAD  PROCEDURE  IN  PROGRESS 
September  10,  1988" 

CHECK  OFF 
COMPUTE 

RECTYPE/Al  =; 

VISIT_CNT/I1=0;  TIME1/I3=0;  PROV2/A5='  TIME2/I3=0; 

PR0V2RES/A1= '  APPSTAT/A1='  • ;REFERAL/A4= ' 

PLACE/A1='  •;  J0BREL/A1='  DUTY/A1='  QTR/A1='  •; 
PR0F/A1='  NAVAIL/A1='  ADMIT/A1='  •  ;  ILLN/A1=' 
INJ/A1='  •;  PURP/A1='  RULE/A1=’  DX1C0DE/A5='  •; 

FIXFORM  SITE/A4  RECTYPE/Al  CL1NIC/C4  VDATE/C6  PROV1/C5 
FIXFORM  PTID/C8  LITHO/C8 
-* 

- 

-♦  RECORD  VALIDATION 

-* 

IF  RECTYPE  GT  '9'  GOTO  TOP; 

IF  RECTYPE  LT  'A'  GOTO  TOP; 

_* - 

-* 

-* 

MATCH  SITE 
ON  MATCH 
ON  NOMATCH 
ON  NOMATCH 
MATCH  CLINIC 
ON  MATCH 
ON  NOMATCH 
ON  NOMATCH 
MATCH  VDATE 
ON  MATCH 
ON  NOMATCH 
ON  NOMATCH 
MATCH  PROVl 
ON  MATCH 


LOAD  OF  THE  VISIT  KEY  DATA  FOR  ALL  FORMS. 


CONTINUE 

INCLUDE 

GOTO  TESTRECT 

CONTINUE 

INCLUDE 

GOTO  TESTRECT 

CONTINUE 

INCLUDE 

GOTO  TESTRECT 

CONTINUE 
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ON  NOMATCH  INCLUDE 
ON  NOMATCH  GOTO  TESTRECT 
MATCH  PTID 

ON  MATCH  CONTINUE 
ON  NOMATCH  INCLUDE 
ON  NOMATCH  GOTO  TESTRECT 
MATCH  LITHO 

ON  MATCH  GOTO  TESTRECT 
ON  NOMATCH  INCLUDE 
ON  NOMATCH  GOTO  TESTRECT 

-* 

CASE  TESTRECT 
COMPUTE 
SITE  =  SITE; 

CLINIC  =  CLINIC; 

VDATE  =  VDATE ; 

PROVl  =  PROVl ; 

PTID  =  PTID; 


LITHO  =  LITHO ; 


IF 

RECTYPE 

EQ 

'  1' 

GOTO 

VALIDFM; 

IF 

RECTYPE 

EQ 

•2' 

GOTO 

PROC2TP; 

IF 

RECTYPE 

EQ 

131 

GOTO 

PROC3TP; 

IF 

RECTYPE 

EQ 

•4  ' 

GOTO 

PROC4TP ; 

IF 

RECTYPE 

EQ 

'5' 

GOTO 

PROC5TP; 

IF 

RECTYPE 

EQ 

•6' 

GOTO 

PROC6TP; 

IF 

RECTYPE 

EQ 

•7' 

GOTO 

PROC7TP; 

IF 

RECTYPE 

EQ 

•8' 

GOTO 

PROC8TP; 

IF 

RECTYPE 

EQ 

•9' 

GOTO 

PROC9TP; 

IF 

RECTYPE 

EQ 

•A' 

GOTO 

PROCATP; 

ENDCASE 

-* - - - 

CASE  VALIDFM 

- 

-* 

-*  RECORD  TRANSACTION  TYPE  PROCESSING  BEGINS 

MATCH  SITE 

ON  MATCH  CONTINUE 
ON  NOMATCH  REJECT 
MATCH  CLINIC 

ON  MATCH  CONTINUE 
ON  NOMATCH  REJECT 
MATCH  VDATE 

ON  MATCH  CONTINUE 
ON  NOMATCH  REJECT 
MATCH  PROVl 

ON  MATCH  CONTINUE 
ON  NOMATCH  REJECT 
MATCH  PTID 

ON  MATCH  CONTINUE 
ON  NOMATCH  REJECT 
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MATCH  LITHO 
ON  MATCH 
FIXFORM  X-36  X36 
FIXFORM  FNUM/2 

FIXFORM  VCNT/1  TIMEl/3  PROV2/5  TIME2/3  PROV2RES/1 

FIXFORM  APPSTAT/1  PLACE/ 1  REFERAL/4  JOBREL/1  DUTY/1 

FIXFORM  QTR/1  PROF/1  NAVAIL/1  ADMIT/1  ILLN/1 

FIXFORM  INJ/1  PURP/1  RULE/1  DXlCODE/5 

ON  MATCH  UPDATE  FNUM  VCNT  TIMEl  PROV2  TIME2  PROV2RES 
ON  MATCH  UPDATE  APPSTAT  PLACE  REFERAL  JOBREL  DUTY  QTR 
ON  MATCH  UPDATE  PROF  NAVAIL  ADMIT  ILLN  INJ  PURP  RULE 
ON  MATCH  UPDATE  DXICODE 
ON  NOMATCH  REJECT 
GOTO  TOP 
ENDCASE 

CASE  PROC2TP 
MATCH  SITE 

ON  MATCH  CONTINUE 
ON  NOMATCH  REJECT 
MATCH  CLINIC 

ON  MATCH  CONTINUE 
ON  NOMATCH  REJECT 
MATCH  VDATE 

ON  MATCH  CONTINUE 
ON  NOMATCH  REJECT 
MATCH  PROVl 

ON  MATCH  CONTINUE 
ON  NOMATCH  REJECT 
MATCH  PTID 

ON  MATCH  CONTINUE 
ON  NOMATCH  REJECT 
MATCH  LITHO 
ON  MATCH 

FIXFORM  X-36  X38  PCODE/5  PRCODE/1 
ON  MATCH  CONTINUE 
ON  NOMATCH  REJECT 
MATCH  PCODE 

ON  MATCH  REJECT 
ON  NOMATCH  INCLUDE 
GOTO  TOP 
ENDCASE 

CASE  PROC3TP 
MATCH  SITE 

ON  MATCH  CONTINUE 
ON  NOMATCH  REJECT 
MATCH  CLINIC 

ON  MATCH  CONTINUE 
ON  NOMATCH  REJECT 
MATCH  VDATE 
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ON  MATCH  CONTINUE 
ON  NOMATCH  REJECT 
MATCH  PROVl 

ON  MATCH  CONTINUE 
ON  NOMATCH  REJECT 
MATCH  PTID 

ON  MATCH  CONTINUE 
ON  NOMATCH  REJECT 
MATCH  LITHO 
ON  MATCH 

FIXFORM  X-36  X38  SPCC/1 
ON  MATCH  COMPUTE 
ON  MATCH  CONTINUE 
ON  NOMATCH  REJECT 
MATCH  SPCC 

ON  MATCH  REJECT 
ON  NOMATCH  INCLUDE 
GOTO  TOP 
ENDCASE 

CASE  PROC4TP 
MATCH  SITE 

ON  MATCH  CONTINUE 
ON  NOMATCH  REJECT 
MATCH  CLINIC 

ON  MATCH  CONTINUE 
ON  NOMATCH  REJECT 
MATCH  VDATE 

ON  MATCH  CONTINUE 
ON  NOMATCH  REJECT 
MATCH  PROVl 

ON  MATCH  CONTINUE 
ON  NOMATCH  REJECT 
MATCH  PTID 

ON  MATCH  CONTINUE 
ON  NOMATCH  REJECT 
MATCH  LITHO 
ON  MATCH 

FIXFORM  X-36  X38  OTHER/ 5 
ON  MATCH  CONTINUE 
ON  NOMATCH  REJECT 
MATCH  OTHER 

ON  MATCH  REJECT 
ON  NOMATCH  INCLUDE 
GOTO  TOP 
ENDCASE 

—  4t**!ft***itik****4t**4t4t**A*4t****ilc***4t*it4tir*4t4tA******4t4r4t:k*it4t4t4t4t*4t 

CASE  PROC5TP 
MATCH  SITE 

ON  MATCH  CONTINUE 
ON  NOMATCH  REJECT 
MATCH  CLINIC 


If 


ON  MATCH  CONTINUE 
ON  NOMATCH  REJECT 
MATCH  VDATE 

ON  MATCH  CONTINUE 
ON  NOMATCH  REJECT 
MATCH  PROVl 

ON  MATCH  CONTINUE 
ON  NOMATCH  REJECT 
MATCH  PTID 

ON  MATCH  CONTINUE 
ON  NOMATCH  REJECT 
MATCH  LITHO 
ON  MATCH 

FIXFORM  X-36  X38  UIC/6  TIMPRl/3  TIMPR2/3  TIMTRl/3  TIMTR2/3 
FIXFORM  MACT/3  OACT/3  RMIL/3  DEPD/3  CIVIL/3  CSHEET/1 
ON  MATCH  CONTINUE 
ON  NOMATCH  REJECT 
MATCH  UIC 

ON  MATCH  REJECT 
ON  NOMATCH  INCLUDE 
GOTO  TOP 
ENDCASE 

CASE  PROC6TP 
MATCH  SITE 

ON  MATCH  CONTINUE 
ON  NOMATCH  REJECT 
MATCH  CLINIC 

ON  MATCH  CONTINUE 
ON  NOMATCH  REJECT 
MATCH  VDATE 

ON  MATCH  CONTINUE 
ON  NOMATCH  REJECT 
MATCH  PROVl 

ON  MATCH  CONTINUE 
ON  NOMATCH  REJECT 
MATCH  PTID 

ON  MATCH  CONTINUE 
ON  NOMATCH  REJECT 
MATCH  LITHO 
ON  MATCH 

FIXFORM  X-36  X38  SPROG/1 
ON  MATCH  CONTINUE 
ON  NOMATCH  REJECT 
MATCH  SPROG 

ON  MATCH  REJECT 
ON  NOMATCH  INCLUDE 
GOTO  TOP 
ENDCASE 

-It********************************************************* 

CASE  PROC7TP 
MATCH  SITE 
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ON  MATCH  CONTINUE 
ON  NOMATCH  REJECT 
MATCH  CLINIC 

ON  MATCH  CONTINUE 
ON  NOMATCH  REJECT 
MATCH  VDATE 

ON  MATCH  CONTINUE 
ON  NOMATCH  REJECT 
MATCH  PROVl 

ON  MATCH  CONTINUE 
ON  NOMATCH  REJECT 
MATCH  PTID 

ON  MATCH  CONTINUE 
ON  NOMATCH  REJECT 
MATCH  LITHO 
ON  MATCH 

FIXFORM  X-36  X38  DX2CODE/5 
ON  MATCH  CONTINUE 
ON  NOMATCH  REJECT 
MATCH  DX2CODE 

ON  MATCH  REJECT 
ON  NOMATCH  INCLUDE 
GOTO  TOP 
ENDCASE 

-********************************************************** 

CASE  PR0C8TP 
MATCH  SITE 

ON  MATCH  CONTINUE 
ON  NOMATCH  REJECT 
MATCH  CLINIC 

ON  MATCH  CONTINUE 
ON  NOMATCH  REJECT 
MATCH  VDATE 

ON  MATCH  CONTINUE 
ON  NOMATCH  REJECT 
MATCH  PROVl 

ON  MATCH  CONTINUE 
ON  NOMATCH  REJECT 
MATCH  PTID 

ON  MATCH  CONTINUE 
ON  NOMATCH  REJECT 
MATCH  LITHO 
ON  MATCH 

FIXFORM  X-36  X38  ASSESMNT/1 
ON  MATCH  CONTINUE 
ON  NOMATCH  REJECT 
MATCH  ARSFSMNT 

ON  MATCH  REJECT 
ON  NOMATCH  INCLUDE 
GOTO  TOP 
ENDCASE 

-.******************************11*************************** 


CASE  PR0C9TP 
MATCH  SITE 

ON  MATCH  CONTINUE 
ON  NOMATCH  REJECT 
MATCH  CLINIC 

ON  MATCH  CONTINUE 
ON  NOMATCH  REJECT 
MATCH  VDATE 

ON  MATCH  CONTINUE 
ON  NOMATCH  REJECT 
MATCH  PROVl 

ON  MATCH  CONTINUE 
ON  NOMATCH  REJECT 
MATCH  PTID 

ON  MATCH  CONTINUE 
ON  NOMATCH  REJECT 
MATCH  LITHO 
ON  MATCH 

FIXFORM  X-36  X38  DISP/2 

ON  MATCH  CONTINUE 
ON  NOMATCH  REJECT 
MATCH  DISP 

ON  MATCH  REJECT 
ON  NOMATCH  INCLUDE 
GOTO  TOP 
ENDCASE 

~it  *************************  ******  ************************** 

CASE  PROCATP 
MATCH  SITE 

ON  MATCH  CONTINUE 
ON  NOMATCH  REJECT 
MATCH  CLINIC 

ON  MATCH  CONTINUE 
ON  NOMATCH  REJECT 
MATCH  VDATE 

ON  MATCH  CONTINUE 
ON  NOMATCH  REJECT 
MATCH  PROVl 

ON  MATCH  CONTINUE 
ON  NOMATCH  REJECT 
MATCH  PTID 

ON  MATCH  CONTINUE 
ON  NOMATCH  REJECT 
MATCH  LITHO 
ON  MATCH 

FIXFORM  X-36  X38  GPATID/11 

ON  MATCH  CONTINUE 
ON  NOMATCH  REJECT 
MATCH  GPATID 

ON  MATCH  REJECT 
ON  NOMATCH  INCLUDE 
GOTO  TOP 
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ENDCASE 

DATA  ON  DETRICK 
END 

TSO  FREE  F( DETRICK) 
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_* - 

-* 

-*  PROCEDURE  OTHLOAD.FEX  PREPARED  BY  D.R. BOLLING 

-*  ON  05/29/87 

-*  LOADS  THE  OTHER  FLAT  FILE  TO  FOCUS  FILE 
- *  ( DETPROC . DATA)  ( PROCEDUR . FOCUS ) 

_* - 

TSO  ALLOC  F(OTHCF)  DA (' DXB. OTHER. MAY87 . CODE ' ) 

-CRTCLEAR 
MODIFY  FILE  OTHER 

TYPE  AT  START  "OTHER  LOAD  PROCEDURE  IN  PROGRESS" 

FIXFORM  OTHER_CODE/5  X2  OTHER_DESCR/67 
-* 

MATCH  OTHER_CODE 

ON  NOMATCH  INCLUDE 
ON  MATCH  CONTINUE 
CHECK  OFF 
DATA  ON  OTHCF 
END 


if 


1 


_* - 

-* 

-*  PROCEDURE  PASILO  .FEX  PREPARED  BY  D.R. BOLLING 

-*  ON  10/09/86 

-*  LOADS  THE  PATIENT  FLAT  FILE  TO  FOCUS  FILE 
-*  (DETPATI.DATA)  (PATIENT. FOCUS) 

-*  REJECTS  DUPLICATE  TRANSACTIONS  FOR  SIDPERS  DATA 

_* - - - - - 

SET  BINS=64 

TSO  ALLOC  F(PATIF)  DA( 'DXB.POLK.AUG87.PATI ' ) 

-CRTCLEAR 

MODIFY  FILE  PATIENT 

TYPE  AT  START  "PATIENT  LOAD  PROCEDURE  IN  PROGRESS" 

FIXFORM  PTID/12 

FIXFORM  PT_DOB/C6  CATEG/A3  PTLITHO/C8 

FIXFORM  REGDATE/C6  SEX/Cl  RACE/Cl  PREFIX/C2  PAYGRADE/C2 
FIXFORM  JOBCODE/C4  PTLOC/C6  TRAINEE/Cl  VA/Cl  HCI/Cl 
ZIP/C5 

FIXFORM  PTDUALSSN/9  PTFORGN/C3 
MATCH  PTID 

ON  NOMATCH  INCLUDE 
ON  MATCH  REJECT 

-* 

CHECK  OFF 
DATA  ON  PATIF 
END 

TSO  FREE  F( PATIF) 
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- - 

-* 

-*  PROCEDURE  PATILOAD.FEX  PREPARED  BY  D.R. BOLLING 

-*  ON  01/10/86 

-*  LOADS  THE  PATIENT  FLAT  FILE  TO  FOCUS  FILE 
-*  (DETPATI.DATA)  (PATIENT. FOCUS) 

-* - 

SET  BINS=63 

TSO  ALLOC  F(PATIF)  DA ( ' DXB . REDS . NOV8 6 . DPATI ' ) 

-CRTCLEAR 

MODIFY  FILE  PATIENT 

TYPE  AT  START  "PATIENT  LOAD  PROCEDURE  IN  PROGRESS" 

FIXFORM  PTID/12 

FIXFORM  PT_DOB/C6  CATEG/A3  PTLITHO/C8 

FIXFORM  REGDATE/C6  SEX/Cl  RACE/Cl  PREFIX/C2  PAYGRADE/C2 
FIXFORM  JOBCODE/C4  PTLOC/C6  TRAINEE/Cl  VA/Cl  HCI/Cl  ZIP/C5 
FIXFORM  PTDUALSSN/9  PTFORGN/C3 
MATCH  PTID 

ON  NOMATCH  INCLUDE 
ON  MATCH  GOTO  SEG2 

CASE  SEG2 
MATCH  PTLITHO 

ON  NOMATCH  REJECT 

ON  MATCH  UPDATE  CATEG  REGDATE  SEX  RACE  PREFIX  PAYGRADE 
ON  MATCH  UPDATE  JOBCODE  PTLOC  TRAINEE  VA  HCI  ZIP 
ON  MATCH  UPDATE  PTDUALSSN  PTFORG 
ENDCASE 
CHECK  OFF 
DATA  ON  PATIF 
END 

TSO  FREE  F( PATIF) 
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PATILD.FEX 


-*  PROCEDURE  PATILD.FEX  PREPARED  BY  D.R. BOLLING  * 
-*  ON  07/07/87  * 
-*  LOADS  THE  PATIENT  FLAT  FILE  TO  FOCUS  FILE  * 
-*  (DETPATI.DATA)  (PATIENT. FOCUS)  * 
-*  LOADS  DEERS  DATA  WITH  UPDATE  CAPABILITY  * 
_* - * 


SET  BINS=63 

TSO  ALLOC  F(PATIF)  DA ( • DXB.REDS .MAY87 . DPATI ' ) 

-CRTCLEAR 

MODIFY  FILE  PATIENT 

TYPE  AT  START  "PATIENT  LOAD  PROCEDURE  IN  PROGRESS" 

FIXFORM  PTID/12  PT_DOB/C6  CATEG/C3  PTLITHO/C8  REGDATE/C6 
FIXFORM  SEX/Cl  RACE/Cl  PREFIX/C2  PAYGRADE/C2  JOBCODE/C4 
FIXFORM  PTLOC/C6  TRAINEE/Cl  VA/Cl  HCI/Cl  ZIP/C5 
FIXFORM  PTDUALSSN/C9  PTFORGN/C3 
MATCH  PTID 

ON  NOMATCH  INCLUDE 

ON  MATCH  UPDATE  CATEG  REGDATE  SEX  RACE  PREFIX  PAYGRADE 
ON  MATCH  UPDATE  JOBCODE  PTLOC  TRAINEE  VA  HCI  ZIP 
ON  MATCH  UPDATE  PTDUALSSN  PTFORGN 
CHECK  OFF 
DATA  ON  PATIF 
END 

TSO  FREE  F (PATIF) 


-* 

-*  PROCEDURE  PROCLOAD.FEX  PREPARED  BY  D.R. BOLLING 

-*  ON  01/10/86 

-*  LOADS  THE  PROCEDURE  FLAT  FILE  TO  FOCUS  FILE 
-*  (DETPROC.DATA)  ( PROCEDUR . FOCUS ) 

-* - 

TSO  ALLOC  F(PROCF)  DA (PROC. DECS 7. CODES) 

-CRTCLEAR 
MODIFY  FILE  NPROC 

TYPE  AT  START  "PROCEDURE  LOAD  PROCEDURE  IN  PROGRESS" 

FIXFORM  PROC_CODE/5  X2  PROC_DESCR/67 
-* 

MATCH  PROC_CODE 

ON  NOMATCH  INCLUDE 
ON  MATCH  UPDATE  PROC_DESCR 
CHECK  OFF 
DATA  ON  PROOF 
END 

TSO  FREE  F(PROCF) 


t# 


1 


-* - 

-* 

-*  PROCEDURE  PROVLOAD.FEX  PREPARED  BY  D.R. BOLLING 

-*  ON  01/10/86 

-*  LOADS  THE  PROVIDER  FLAT  FILE  TO  FOCUS  FILE 
-*  ( DETPROV . DATA)  ( PROVIDER . FOCUS ) 

-* - 


TSO  ALLOC  F(PROVF)  DA ( 'DXB.PROV. FIXED ' ) 

-CRTCLEAR 

MODIFY  FILE  PROVIDER 

TYPE  AT  START  "PROVIDER  LOAD  PROCEDURE  IN  PROGRESS" 
FIXFORM  PROVID/9  PROVDATE/6 
FIXFORM  PRSTAT/1  PRCATEG/2  PRPOS/2 
FIXFORM  PRPAYGR/2  PRJCODE/7  PRLTH/8 
-* 


MATCH  PROVID 

ON  NOMATCH  INCLUDE 
ON  MATCH  REJECT 
CHECK  OFF 
DATA  ON  PROVF 
END 

TSO  FREE  F( PROVF) 


1 


-♦PROCEDURE  RXXF400.FEX  PREPARED  BY:  D.R.B. 

-*  ON:  01/03/86 

-♦LOADS  THE  VISIT  DATA  BASE  ,  ALL  SEGMENTS  INTO  MAIN  FRAME 

-* 

-♦  READS  BASE  32  SSN 

-♦  PREVENT  DATA  OFFSET  BY  MOVING  FIXFORM  AFTER  LITHO  MATCH 
-♦  05/20/86 

-♦  ALLOW  FOR  FORM  NUMBER  FIELD  07/01/86 

-♦  LOADS  DATA  INTO  BAMC  DATA  BASE  (VBAMC)  01/14/87 


SET  BINS=64 

TSO  ALLOC  F(DETRICK)  DA{ • DXB.U. BAMC. OLD87 . VISIT ' )  SHR 

-START 

-RUN 

-CRTCLEAR 
MODIFY  FILE  VBAMC 
-* 

TYPE  AT  START  "ENCOUNTER  LOAD  PROCEDURE  IN  PROGRESS 
September  10,  1988" 

CHECK  OFF 
COMPUTE 

RECTYPE/Al  =; 

-♦VISRES/A1='  TIME1/I3=0;  PROV2/A5='  '?  TIME2/I3=0; 

-♦PR0V2RES/A1='  PR0V1SEEN/A1= »  PR0V1SAME/A1= '  •; 

-♦PR0V2SEEN/A1='  PR0V2SAME/A1= '  LAST12/A1=' 

-♦NEWPR0B/A1= '  ' ;APPSTAT/A1=‘  * ;REFERAL/A4* •  •? 

-*PLACE/A1='  ' ;J0BREL/A1='  •;DISP0/A1=*  ';LAB/A1=' 
-*RX/A1=»  •;  DX1RULE/A1='  ' ;DXlCODE/A5=' 

FIXFORM  SITE/A4 
FIXFORM  RECTYPE/Al 

FIXFORM  CLINIC/C4  VDATE/C6  PROV1/C5 

FIXFORM  PTID/C8  LITHO/C8 


RECORD  VALIDATION 


IF  RECTYPE  GT  '9' 
IF  RECTYPE  LT  '1' 


GOTO  TOP; 
GOTO  TOP; 


LOAD  OF  THE  VISIT  KEY  DATA  FOR  ALL  FORMS. 


MATCH  SITE 


ON  MATCH  CONTINUE 
ON  NOMATCH  INCLUDE 
ON  NOMATCH  GOTO  TESTRECT 
MATCH  CLINIC 

ON  MATCH  CONTINUE 
ON  NOMATCH  INCLUDE 
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ON  NOMATCH  GOTO  TESTRECT 
MATCH  VDATE 

ON  MATCH  CONTINUE 
ON  NOMATCH  INCLUDE 
ON  NOMATCH  GOTO  TESTRECT 
MATCH  PROVl 

ON  MATCH  CONTINUE 
ON  NOMATCH  INCLUDE 
ON  NOMATCH  GOTO  TESTRECT 
MATCH  PTID 

ON  MATCH  CONTINUE 
ON  NOMATCH  INCLUDE 
ON  NOMATCH  GOTO  TESTRECT 
MATCH  LITHO 

ON  MATCH  GOTO  TESTRECT 
ON  NOMATCH  INCLUDE 
ON  NOMATCH  GOTO  TESTRECT 

-* 


CASE  TESTRECT 
COMPUTE 

SITE  =  SITE; 

CLINIC  =  CLINIC; 

VDATE  =  VDATE 

• 

PROVl  =  PROVl 
PTID  =  PTID; 

• 

§ 

LITHO  «  LITHO 

• 

t 

IF  RECTYPE  EQ 

•1' 

GOTO 

VALIDFM; 

IF  RECTYPE  EQ 

•2' 

GOTO 

PROC2TP; 

IP  RECTYPE  EQ 

•3' 

GOTO 

PROC3TP; 

IF  RECTYPE  EQ 

•4' 

GOTO 

PROC4TP; 

IF  RECTYPE  EQ 

•5' 

GOTO 

PROC5TP; 

IF  RECTYPE  EQ 

'-6' 

GOTO 

PROC6TP; 

IF  RECTYPE  EQ 

171 

GOTO 

PROC7TP; 

IF  RECTYPE  EQ 

•8' 

GOTO 

PROC8TP; 

IF  RECTYPE  EQ 
ENDCASE 

191 

GOTO 

PROC9TP; 

-* - 

CASE  VALIDFM 
-* - 


-*  COMMON  FORM 

“*  RECORD  TRANSACTION  TYPE  PROCESSING  BEGINS 

— * 

MATCH  SITE 

ON  MATCH  CONTINUE 
ON  NOMATCH  REJECT 
MATCH  CLINIC 

ON  MATCH  CONTINUE 
ON  NOMATCH  REJECT 
MATCH  VDATE 

ON  MATCH  CONTINUE 
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ON  NOMATCH  REJECT 
MATCH  PROVl 

ON  MATCH  CONTINUE 
ON  NOMATCH  REJECT 
MATCH  PTID 

ON  MATCH  CONTINUE 
ON  NOMATCH  REJECT 

-* 

MATCH  LITHO 
ON  MATCH 
FIXFORM  X-36 
FIXFORM  X36  FNUM/C2 

FIXFORM  VISRES/Cl  TIME1/C3  PROV2/C5  TIME2/C3  PROV2RES/C1 
FIXFORM  PROVISEEN/Cl  PROVISAME/Cl  PROV2SEEN/C1 

FIXFORM  PROV2SAME/C1  LAST12/C1  NEWPROB/Cl 

FIXFORM  APPSTAT/Cl  REFERAL/C4  PLACE/Cl  JOBREL/Cl 

FIXFORM  DISPO/Cl  LAB/Cl  RX/Cl 

FIXFORM  PRPVST/Cl  RELSURV/Cl  ADMREAS/Cl 

FIXFORM  DXIRULE/Cl  DX1CODE/C5 

ON  NOMATCH  REJECT 
ON  MATCH  CONTINUE  TO  VISRES 
ON  NOMATCH  INCLUDE 
ON  MATCH  REJECT 
ENDCASE 

CASE  PROC2TP 
MATCH  SITE 

§§  ON  MATCH  CONTINUE 

ON  NOMATCH  REJECT 
MATCH  CLINIC 

ON  MATCH  CONTINUE 
ON  NOMATCH  REJECT 
MATCH  VDATE 

ON  MATCH  CONTINUE 
ON  NOMATCH  REJECT 
MATCH  PROVl 

ON  MATCH  CONTINUE 
ON  NOMATCH  REJECT 
MATCH  PTID 

ON  MATCH  CONTINUE 
ON  NOMATCH  REJECT 
MATCH  LITHO 
ON  MATCH 
FIXFOPM  X-36 
FIXFORM  X38 
FIXFORM  PCODE/5 

ON  MATCH  CONTINUE 
ON  NOMATCH  REJECT 
MATCH  PCODE 

ON  MATCH  REJECT 
ON  NOMATCH  INCLUDE 
GOTO  TOP 
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ENDCASE 

— •kit  hit  It  It -k  Ifklfk  Ifk  hit  hh  hit  lilt  h  hit  hit  hit  It  hit  it  it -kit  It  It  It  hlth -kit  h -kit  It  hit  h  hit  It 


CASE 

PROC3TP 

MATCH 

SITE 

ON 

MATCH 

CONTINUE 

ON 

NOMATCH 

REJECT 

MATCH 

CLINIC 

ON 

MATCH 

CONTINUE 

ON 

NOMATCH 

REJECT 

MATCH 

VDATE 

ON 

MATCH 

CONTINUE 

ON 

NOMATCH 

REJECT 

MATCH 

PROVl 

ON 

MATCH 

CONTINUE 

ON 

NOMATCH 

REJECT 

MATCH 

PTID 

ON 

MATCH 

CONTINUE 

ON 

NOMATCH 

REJECT 

MATCH 

LITHO 

ON  MATCH 
FIXFORM  X-36 
FIXFORM  X38 
FIXFORM  SUPPDISP/1 
ON  MATCH  CONTINUE 
ON  NOMATCH  REJECT 
MATCH  SUPPDISP 

ON  MATCH  REJECT 
ON  NOMATCH  INCLUDE 
GOTO  TOP 
ENDCASE 

-hhhhhhhhhhhhh ********************************************* 


CASE 

PROC4TP 

MATCH 

SITE 

ON 

MATCH 

CONTINUE 

ON 

NOMATCH 

REJECT 

MATCH 

CLINIC 

ON 

MATCH 

CONTINUE 

ON 

NOMATCH 

REJECT 

MATCH 

VDATE 

ON 

MATCH 

CONTINUE 

ON 

NOMATCH 

REJECT 

MATCH 

PROVl 

ON 

MATCH 

CONTINUE 

ON 

NOMATCH 

REJECT 

MATCH 

PTID 

ON 

MATCH 

CONTINUE 

ON 

NOMATCH 

REJECT 

MATCH 

LITHO 

ON  MATCH 
FIXFORM  X-36 
FIXFORM  X38 
FIXFORM  XRAY/l 
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ON  MATCH  CONTINUE 
ON  NOMATCH  REJECT 
MATCH  XRAY 

ON  MATCH  REJECT 
ON  NOMATCH  INCLUDE 
GOTO  TOP 
ENDCASE 

-It********************************************************* 

CASE  PROC5TP 
MATCH  SITE 

ON  MATCH  CONTINUE 
ON  NOMATCH  REJECT 
MATCH  CLINIC 

ON  MATCH  CONTINUE 
ON  NOMATCH  REJECT 
MATCH  VDATE 

ON  MATCH  CONTINUE 
ON  NOMATCH  REJECT 
MATCH  PROVl 

ON  MATCH  CONTINUE 
ON  NOMATCH  REJECT 
MATCH  PTID 

ON  MATCH  CONTINUE 
ON  NOMATCH  REJECT 
MATCH  LITHO 
ON  MATCH 
FIXFORM  X-36 
FIXFORM  X38 
FIXFORM  OTHORD 

ON  MATCH  CONTINUE 
ON  NOMATCH  REJECT 
MATCH  OTHORD 

ON  MATCH  REJECT 
ON  NOMATCH  INCLUDE 
GOTO  TOP 
ENDCASE 

CASE  PROC6TP 
MATCH  SITE 

ON  MATCH  CONTINUE 
ON  NOMATCH  REJECT 
MATCH  CLINIC 

ON  MATCH  CONTINUE 
ON  NOMATCH  REJECT 
MATCH  VDATE 

ON  MATCH  CONTINUE 
ON  NOMATCH  REJECT 
MATCH  PROVl 

ON  MATCH  CONTINUE 
ON  NOMATCH  REJECT 
MATCH  PTID 

ON  MATCH  CONTINUE 


ON  NOMATCH  REJECT 
MATCH  LITHO 
ON  MATCH 
FIXFORM  X-36 
FIXFORM  X38 
FIXFORM  SPROG/2 

ON  MATCH  CONTINUE 
ON  NOMATCH  REJECT 
MATCH  SPROG 

ON  MATCH  REJECT 
ON  NOMATCH  INCLUDE 
GOTO  TOP 
ENDCASE 

—  ***********4r******ik*4r*Ai^*#*****ik******A****4t*A**4t**4t*4t*4t** 

CASE  PROC7TP 
MATCH  SITE 

ON  MATCH  CONTINUE 
ON  NOMATCH  REJECT 
MATCH  CLINIC 

ON  MATCH  CONTINUE 
ON  NOMATCH  REJECT 
MATCH  VDATE 
ON  MATCH  CONTINUE 
ON  NOMATCH  REJECT 
MATCH  PROVl 

ON  MATCH  CONTINUE 
ON  NOMATCH  REJECT 
MATCH  PTID 

ON  MATCH  CONTINUE 
ON  NOMATCH  REJECT 
MATCH  LITHO 
ON  MATCH 
FIXFORM  X-36 
FIXFORM  X38 

FIXFORM  DX2RULE/C1  DX2CODE/5 
ON  MATCH  CONTINUE 
ON  NOMATCH  REJECT 
MATCH  DX2CODE 

ON  MATCH  REJECT 
ON  NOMATCH  INCLUDE 
GOTO  TOP 
ENDCASE 

-It********************************************************* 

CASE  PROC8TP 
MATCH  SITE 

ON  MATCH  CONTINUE 
ON  NOMATCH  REJECT 
MATCH  CLINIC 

ON  MATCH  CONTINUE 
ON  NOMATCH  REJECT 
MATCH  VDATE 

ON  MATCH  CONTINUE 


ON  NOMATCH  REJECT 
MATCH  PROVl 

ON  MATCH  CONTINUE 
ON  NOMATCH  REJECT 
MATCH  PTID 

ON  MATCH  CONTINUE 
ON  NOMATCH  REJECT 
MATC»LITHO 
ONJKTCH 
FlfpORM  X-36 
FIXFORM  X38 
FJXFORM  ASSESMNT/2 
ON  MATCH  CONTINUE 
ON  NOMATCH  REJECT 
MATCH  ASSESMNT 

ON  MATCH  REJECT 
ON  NOMATCH  INCLUDE 
GOTO  TOP 
ENDCASE 

-*********1Hi1t  ******  **************************************** 

CASE  PROC9TP 
MATCH  SITE 

ON  MATCH  CONTINUE 
ON  NOMATCH  REJECT 
MATCH  CLINIC 

ON  MATCH  CONTINUE 
ON  NOMATCH  REJECT 
MATCH  VDATE 

ON  MATCH  CONTINUE 
ON  NOMATCH  REJECT 
MATCH  PROVl 

ON  MATCH  CONTINUE 
ON  NOMATCH  REJECT 
MATCH  PTID 

ON  MATCH  CONTINUE 
ON  NOMATCH  REJECT 
MATCH  LITHO 
ON  MATCH 
FIXFORM  X-36 
FIXFORM  X38 
FIXFORM  MCODE/6 

ON  MATCH  CONTINUE 
ON  NOMATCH  REJECT 
MATCH  MCODE 

ON  MATCH  REJECT 
ON  NOMATCH  INCLUDE 
GOTO  TOP 
ENDCASE 

-********************************************************** 

DATA  ON  DETRICK 

END 

TSO  FREE  F( DETRICK) 
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APPENDIX  F 


€• 


MAINFRAME  SAS  PROGRAMS  (REFERENCED  SECTION  6.2.4) 


APPENDIX  F 


DEERS 

PATD32 

SIDCONV 


MAINFRAME  SAS  PROGRAMS 
TABLE  OF  CONTENTS 


DEERS  Conversion 

Patient  Social  Security  Encryption 
SIDPERS  Conversion 


Note:  The  listings  in  this  appendix  were 

prepared  by  downloading  the  mainframe  programs  to  a  PC 
for  printing.  In  doing  so,  some  IBM  EBCDIC  characters 
are  not  converted  to  ASCII  properly.  Two  characters 
may  be  noticed  on  the  listings.  They  are  the  'not 
equal '  character  and  a  vertical  bar  used  to  represent 
concatenation.  The  'not  equal'  character  will  be  seen 
as  '“='.  The  vertical  bar  will  be  shown  as 


//DXBP  JOB  (PlOl)  ,  BOLLING, CIASS=*R,MSGCLASS=X 

/ /  EXEC  SAS 

//DBl  DD  DSN=DXB. REDS. MAYS 7. DEERS, DISP=SHR 

//DB2  DD  DSN=DXB. REDS. MAY87C. DEERS, DISP=OLD 

DATA  A; 

LENGTH  LITHO  $  8; 

LENGTH  Z  $  1; 

INFILE  DBl  ; 

FILE  DB2; 

INPUT  SSN  $  1-9  DEPSEQ  $  11-12  PUIC  $  40-45  ZIP  $  107-111 
BRANCH  $  116  PAYGR  $  117-118  SEX  $  119 
DOB  $  121-126  SPONST  $  127; 

UIC='  ' ; 

IF  SPONST  =  'A'  THEN  UIC=PUIC; 

IF  SPONST  =  'B'  THEN  UIC=PUIC; 

IF  SPONST  =  'E'  THEN  UIC=PUIC; 

IF  SPONST  =  'J'  THEN  UIC=PUIC; 

IF  SPONST  =  'N'  THEN  UIC=PUIC; 

IF  SPONST  =  'V  THEN  UIC=PUIC; 

IF  SPONST  =  'Z'  THEN  UIC=PUIC; 

IF  SUBSTR(PUIC, 1, 1) '=  'W'  THEN  UIC='  •; 

CAT='X70' ; 

IF  SPONST  ='A'  THEN 

IF  BRANCH  ='A'  AND  DEPSEQ='20'  THEN  CAT='A10';  ELSE 
IF  BRANCH  ='A'  AND  DEPSEQ*='20'  THEN  CAT='A50';  ELSE 
IF  BRANCH  ='I'  AND  DEPSEQ='20'  THEN  CAT='010';  ELSE 
IF  BRANCH  ='!'  AND  DEPSEQ"*’ 20 '  THEN  CAT='050’ ;  ELSE 
IF  BRANCH  =’N’  AND  DEPSEQ* '20'  THEN  CAT*'N10',*  ELSE 
IF  BRANCH  ='N'  AND  DEPSEQ"*' 20'  THEN  CAT*'N50';  ELSE 
IF  BRANCH  ='M'  AND  DEPSEQ* *20'  THEN  CAT=»M10';  ELSE 
IF  BRANCH  ='M'  AND  DEPSEQ"*'20'  THEN  CAT='M50';  ELSE 
IF  BRANCH  ='F'  AND  DEPSEQ* '20'  THEN  CAT='F10';  ELSE 
IF  BRANCH  ='F'  AND  DEPSEQ"*' 20'  THEN  CAT='F50';  ELSE 
IF  BRANCH  ='P'  AND  DEPSEQ* '20'  THEN  CAT='C10';  ELSE 
IF  BRANCH  ='P'  AND  DEPSEQ"*' 20'  THEN  CAT='C50';  ELSE 
IF  BRANCH  *'E'  AND  DEPSEQ*' 20'  THEN  CAT='P10';  ELSE 
IF  BRANCH  ='E'  AND  DEPSEQ"*' 20'  THEN  CAT='P50';  ELSE 
CAT='X70' ; 

IF  SPONST  ='B'  THEN 

IF  BRANCH  ='A'  AND  DEPSEQ* '20'  THEN  CAT='A10';  ELSE 
IF  BRANCH  ='A'  AND  DEPSEQ"* '20'  THEN  CAT='A50';  ELSE 
IF  BRANCH  ='!'  AND  DEPSEQ*' 20'  THEN  CAT* '010';  ELSE 
IF  BRANCH  ='!'  AND  DEPSEQ"* '20'  THEN  CAT* '050';  ELSE 
IF  BRANCH  ='N'  AND  DEPSEQ* '20'  THEN  CAT*'N10';  ELSE 
IF  BRANCH  ='N'  AND  DEPSEQ"* '20'  THEN  CAT*'N50';  ELSE 
IF  BRANCH  ='M'  AND  DEPSEQ* '20'  THEN  CAT='M10';  ELSE 
IF  BRANCH  ='M'  AND  DEPSEQ"*'20'  THEN  CAT*'M50';  ELSE 
IF  BRANCH  ='F'  AND  DEPSEQ* '20'  THEN  CAT='F10';  ELSE 
IF  BRANCH  *'F'  AND  DEPSEQ"* '20'  THEN  CAT*'F50';  ELSE 
IF  BRANCH  ='P'  AND  DEPSEQ* '20'  THEN  CAT* 'CIO';  ELSE 
IF  BRANCH  ='P'  AND  DEPSEQ"*'20'  THEN  CAT*'C50';  ELSE 
IF  BRANCH  *'E'  AND  DEPSEQ* '20'  THEN  CAT*'P10';  ELSE 
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IF  BRANCH  ='E' 
CAT='X70' ; 

IF  SPONST  ='N 
IF  BRANCH  = 

IF  BRANCH  = 

IF  BRANCH  » 
CAT='X70' ; 

IF  SPONST  ='R 


AND  DEPSEQ"=*20'  THEN  CAT='P50' 


IF 

BRANCH 

=  'A' 

AND 

IF 

BRANCH 

=  'A' 

AND 

IF 

BRANCH 

=  •!' 

AND 

IF 

BRANCH 

=  '!' 

AND 

IF 

BRANCH 

=  'N' 

AND 

IF 

BRANCH 

=  'N' 

AND 

IF 

BRANCH 

=  'M' 

AND 

IF 

BRANCH 

=  'M' 

AND 

IF 

BRANCH 

=  •  F  • 

AND 

IF 

BRANCH 

=  1 F ' 

AND 

IF 

BRANCH 

=  tpi 

AND 

IF 

BRANCH 

=  ipi 

AND 

IF 

BRANCH 

=  »E' 

AND 

IF 

BRANCH 

=  'E' 

AND 

CAT='X70' 

IF  SPONST  ='V 


IF 

BRANCH  ='A' 

AND  ] 

IF 

BRANCH  ='A' 

AND  1 

IF 

BRANCH  ='!' 

AND  I 

IF 

BRANCH  ='N' 

THEN 

IF 

BRANCH  ='M' 

THEN 

IF 

BRANCH  ='F' 

THEN 

IF 

BRANCH  ='P' 

THEN 

IF 

BRANCH  ='E' 

THEN 

CAT='X70' ; 

IF  SPONST  ='J'  THEN 

IF 

BRANCH  ='A' 

THEN 

IF 

BRANCH  ='N' 

THEN 

IF 

BRANCH  ='F' 

THEN 

IF 

BRANCH  ='P' 

THEN 

CAT='X70' ; 


THEN 


THEN 


AND  DEPSEQ= '20'  THEN  CAT= ' A2  6 ' ; 
AND  DEPSEQ*='20'  THEN  CAT='A50' 
THEN  CAT= • F2  0 • ;  ELSE 


DEPSEQ=' 
DEPSEQ*= 
DEPSEQ= • 
DEPSEQ"= 
DEPSEQ=' 
DEPSEQ"= 
DEPSEQ= • 
DEPSEQ"= 
DEPSEQ=' 
DEPSEQ*= 
DEPSEQ= • 
DEPSEQ*= 
DEPSEQ= • 
DEPSEQ“= 


20'  THEN  CAT= 
•20'  THEN  CAT 
20*  THEN  CAT= 
•20'  THEN  CAT 
20*  THEN  CAT= 
•20*  THEN  CAT 
THEN  CAT= 
•  THEN  CAT 
THEN  CAT= 
'  THEN  CAT^ 
THEN  CAT= 
'  THEN  CAT 
THEN  CAT= 


20* 

•20' 

20' 

•20' 

20' 

•20' 

20' 


•20'  THEN  CAT 


•A30' 
=  'A60 
•030' 
=  '060 
•N30’ 
=  'N60 
•M30' 
=  'M60 
•F30' 
=  'F60 
•C30' 
=  'C60 
•P30  ' 
=  'P60 


THEN 


DEPSEQ='20' 
?SEQ‘  =  '20 
DEPSEQ='20' 
CAT=’N20» ; 
CAT='M20' ; 
CAT='F20' ? 
CAT=*C20' ; 
CAT='P20' ; 


THEN  CAT='A23'; 
'  THEN  CAT='A50' 


THEN 

ELSE 

ELSE 

ELSE 

ELSE 

ELSE 


CAT='020 


CAT='A70';  ELSE 
CAT='N70';  ELSE 
CAT='F70';  ELSE 
CAT='C70';  ELSE 


THEN  CAT='X30'; 
THEN  CAT='K10'; 
THEN  CAT=*X70»; 
THEN  CAT='X20'; 
AND  DEPSEQ='20' 


IF  SPONST  ='C 
IF  SPONST  ='D 
IF  SPONST  ='Z 
IF  SPONST  ='S 
IF  SPONST  ='E 
XX+l; 

LITHO=XX; 

DATE= ' 870501  •  ; 

IF  SEX='M'  THEN 
ELSE  IF  SEX=* 

RACE= '  • ; 

PREF= •  '  ; 

IF  •00'<=  PAYGR  <=  '09'  THEN  PREF='E  '; 


THEN  CAT='X20' 


SEX='M'  ; 

F'  THEN  SEX='F';ELSE  SEX='  '; 


;  ELSE 


ELSE 
;  ELSE 


ELSE 

ELSE 

ELSE 

ELSE 

ELSE 

ELSE 

ELSE 

ELSE 

ELSE 

ELSE 

ELSE 

ELSE 

ELSE 

ELSE 


ELSE 
;  ELSE 
ELSE 
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IF 

'10'<®  PAYGR 

<= 

'14' 

THEN 

PREF»'W  '; 

IF 

'20'<®  PAYGR 

<» 

'30' 

THEN 

PREF®'0  '; 

IF 

'44'<®  PAYGR 

<* 

'49' 

THEN 

PREF='E  '; 

IF 

'01'<®  PAYGR 

<= 

'09' 

THEN 

PAYGR® PAYGR; 

ELSE  IF  'll' 

<= 

PAYGR  <® 

'14*  THEN  DO; 

Z=PAYGR-10; 

PAYGR= ’ 0 • ] ] Z ; 

END; 

ELSE  IF  '21'<=  PAYGR  <=  '29'  THEN  DO; 


Z=PAYGR-20 ; 

PAYGR® ' 0 • ] ] Z ; 

END; 

ELSE  IF  PAYGR=  *30'  THEN  PAYGR®PAYGR-20 ; 
ELSE  IF  •44'<=  PAYGR  <®  '49'  THEN  DO; 
Z=PAYGR-40; 


PAYGR® ' 0 ' ] ] Z ; 
END; 

ELSE  PAYGR* •  • ; 

PAD® •  •  ; 


PAD3* • 


PAD2® •  •  ; 

PUT  SSN  $9.  DEPSEQ  $2.  DOB  $6 
SEX  $1.  RACE  $1.  PREF  $2. 
PAD3  $3.  ZIP  $5.  PAD2  $12 


CAT  $3.  LITHO  $8 
PAYGR  $2.  PAD  $4. 


DATE  $6. 
UIC  $6. 
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//DXBS  JOB  (PlOl) , BOLLING, CIASS=R,MSGCLASS=X 

//  EXEC  SAS,WORK=»90,10* 

//DBl  DD  DSN=DXB.BAMC.MAY87C. DEERS, DISP=SHR 

//DB2  DD  DSN»DXB . BAMC . MAY87 . DPATI , DISP=SHR 

PROC  FORMAT; 

VALUE  CODE  0  ='A*  1  ='B*  2  ='C'  3**D'  4='E'  5='F'  6='G‘ 
7*'H'  8='I'  9=«'J'  10='K'  11=’L'  12='M'  13='N'  14='0'  15='P' 
16*'Q'  17='R'  18='S'  19='T'  20='U'  21='V'  22='2'  23='3' 
24«'4'  25='5'  26='6'  27='7'  28=*8'  29='9'  30='0'  31='!' 

32='  •; 

DATA  A; 

INFILE  DBl  ; 

FILE  DB2; 

INPUT  SSN  1-9  FMP  $CHAR2 .  OTH  $CHAR59 . ; 

SITE* ’ 0109 • ; 

Kl=INT(SSN/33554432) ; 

SSN=SSN-K1*33554432 ; 

K2=INT(SSN/1048576) ; 

SSN*SSN-K2*1048576 ; 

K3=INT(SSN/32768) ; 

SSN*SSN-K3*32768 ; 

K4=INT(SSN/1024) ; 

SSN*SSN-K4*1024; 

K5=INT(SSN/32) ; 

SSN*SSN-K5*32; 

K6=SSN ; 

PUT  SITE  $4.  K1  CODEl.  K2  CODEl.  K3  CODEl.  K4  CODEl.  K5 
CODEl.  K6  CODEl.  FMP  $2.  OTH  $59.; 
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//DXBU  JOB  (PlOl) , BOLLING, CIASS=R,MSGCLASS=X 

//  EXEC  SAS 

//DBl  DD  DSN=DXB.POLK.AUG87S.SIDATA,DISP=SHR 

//DB2  DD  DSN=DXB . POLK . AUG87 . PATI , DISP=OLD 

* - 

*  SIDPERS  CONVERSION  PROGRAM 

*  - 

PROC  FORMAT; 

VALUE  CODE  0  ='A'  1  ='B'  2  =*C'  3='D'  4='E'  5=*F' 
7='H'  8='I'  9='J'  1C='K'  11='L'  12=*M'  13='N'  14='0' 


) 

) 

); 


6='G' 

15='P' 


16='Q'  17='R'  18='S'  19='T'  20='U'  21='V'  22='2'  23='3' 
24='4'  25='5'  26='6'  27='7'  28='8*  29='9'  30='0'  31='!' 
32=' 

DATA  A; 

LENGTH  LITHO  $  7; 

* - ) 

*  IMPORTANT:  CHANGE  SITE  CODE  (C)  AND  DATE  (YYMMDD)  ) 

*  ) 

*  B=BRAGG  C=CAMPBELL  J=JACKSON  P=POLK  ) 

*  ) 

* - ). 

C= ' P • ; 

DATE=' 870930* ; 

* - )  . 

FMP='20' ; 

CAT='A10' ; 

W='W' ; 

PAD1='  * ; 

PAD12- *  '  ; 

PAD3='  •; 

INFILE  DBl  ; 

FILE  DB2; 

INPUT  SSN  1-9  MPC  $  10  GRADE  $  11  SEX  $  12  MOS  $CHAR5. 
UPCl  $CHAR5.  DOB  $CHAR6.  RACE  $  29; 

XX+1; 

LITHO=XX; 


ZIP='  •; 

IF  C='B'  THEN  DO;  ZIP=' 28307';  SITE* *0089';  END; 
IF  C*'C'  THEN  DO;  ZIP*'42223';  SITE='0060';  END; 
IF  C='J'  THEN  DO;  ZIP='29207';  SITE=*0105';  END; 
IF  C='P'  THEN  DO;  ZIP='71459';  SITE='0064';  END; 


*  CONVERT  GRADE 


IF  MPC=*E'  THEN  GOTO  ENLIST; 
IF  MPC='0'  THEN  GOTO  OFFICE; 
*  ASSUME  MPC  IS  W 


IF 

GRADE* 'U* 

THEN 

DO; 

GRAD*  *  04 ' ; 

GOTO 

GREND; 

END 

IF 

GRADE* 'V* 

THEN 

DO; 

GRAD*  *  03 ' ; 

GOTO 

GREND; 

END 

IF 

GRADE* 'W* 

THEN 

DO; 

GRAD*  *  02 ' ; 

GOTO 

GREND; 

END 

IF 

GRADE*'X' 

THEN 

DO; 

GRAD*'01' ; 

GOTO 

GREND; 

END 
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FILE  LOG; 

PUT  'ERROR  IN  GRADE  MPC 
FILE  DB2; 

GRAD*'  •; 

GOTO  GREND; 

* . 


:*'  MPC  ' GRADE* •  GRADE; 


*  GRADE  CONVERSION 

WHEN 

MPC 

:*E 

ENLIST;  IF 

GRADE* 'M' 

THEN 

DO 

GRAD*' 

04'  ; 

IF 

GRADE* 'N' 

THEN 

DO 

GRAD*' 

05’  ; 

IF 

GRADE*'0' 

THEN 

DO 

GRAD*' 

06*  ; 

IF 

GRADE* 'P' 

THEN 

DO 

GRAD*' 

07'  ; 

IF 

GRADE* 'R' 

THEN 

DO 

GRAD*' 

09'  ; 

IF 

GRADE* ' X ' 

THEN 

DO 

GRAD*’ 

07'  ; 

IF 

GRADE* ' Y ' 

THEN 

DO 

GRAD*' 

08'  ; 

IF 

GRADE*'!' 

THEN 

DO 

GRAD*' 

01'  ; 

IF 

GRADE*' 2' 

THEN 

DO 

GRAD*' 

02'  ; 

IF 

GRADE* ' 3 ' 

THEN 

DO 

GRAD*' 

03' ; 

IF 

GRADE* ' 4 ' 

THEN 

DO 

GRAD*' 

04'  ; 

IF 

GRADE*' 5' 

THEN 

DO 

GRAD*' 

05' ; 

IF 

GRADE='6' 

THEN 

DO 

GRAD*' 

06' ; 

IF 

GRADE*' 7* 

THEN 

DO 

GRAD*' 

07'  ; 

IF 

GRADE*' 8' 

THEN 

DO 

GRAD*' 

08'  ; 

IF 

GRADE* • 9 ' 

THEN 

DO 

GRAD*' 

09' ; 

GOTO 

GOTO 

GOTO 

GOTO 

GOTO 

GOTO 

GOTO 

GOTO 

GOTO 

GOTO 

GOTO 

GOTO 

GOTO 

GOTO 

GOTO 

GOTO 


GREND 

GREND 

GREND 

GREND 

GREND 

GREND 

GREND 

GREND 

GREND 

GREND 

GREND 

GREND 

GREND 

GREND 

GREND 

GREND 


FILE  LOG; 

PUT  'ERROR  IN  GRADE  MPC*'  MPC 
FILE  DB2; 

GRAD* •  ' ; 

GOTO  GREND; 

* . . . 

*  GRADE  CONVERSION  WHEN  MPC*0 


:='  MPC  ' GRADE* •  GRADE; 


FILE  LOG; 

PUT  'ERROR  IN  GRADE  MPC 
FILE  DB2; 

GRAD* '  ' ; 

* . 

*  CONVERT  RACE 


*'  MPC  'GRADE*'  GRADE; 


IF 

RACE* '  ' 

THEN 

RACE* ' 7 ' 

IF 

RACE* ' C ' 

THEN 

RACE* ' 5 ' 

IF 

RACE='M' 

THEN 

RACE* ' 2 ' 

IF 

RACE='N' 

THEN 

RACE* ’ 4 ' 

IF 

RACE*'R' 

THEN 

RACE* ’ 1 ' 

IF 

RACE* ' X ' 

THEN 

RACE* ' 7 ' 

IF 

GRADE* 'A' 

THEN 

DO 

GRAD* '08' 

GOTO 

GREND ; 

IF 

GRADE* 'B' 

THEN 

DO 

GRAD* ' 06 ' 

GOTO 

GREND; 

IF 

GRADE* ' C ' 

THEN 

DO 

GRAD* '05' 

GOTO 

GREND 

IF 

GRADE* ' D ' 

THEN 

DO 

GRAD*' 04' 

GOTO 

GREND 

IF 

GRADE* ' E ' 

THEN 

DO 

GRAD* '03' 

GOTO 

GREND 

IF 

GRADE* 'F' 

THEN 

DO 

GRAD* '02' 

GOTO 

GREND; 

IF 

GRADE* 'G' 

THEN 

DO 

GRAD* '01' 

GOTO 

GREND; 

IF 

GRADE* ' 5 ' 

THEN 

DO 

GRAD*’ 03' 

GOTO 

GREND; 

IF 

GRADE*' 6' 

THEN 

DO 

GRAD*' 02' 

GOTO 

GREND; 

IF 

GRADE* ' 7 ' 

THEN 

DO 

GRAD* '01' 

GOTO 

GREND; 

END; 

END; 

END; 

END; 

END; 

END; 

END; 

END; 

END; 

END; 
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* 


CONVERT  JOB  CODE 

IF  MPO'E'  THEN  JC*'0']  ]SUBSTR(MOS,  1,3)  i 
IF  MPC=*0'  THEN  JC*' O' ] ]SUBSTR(MOS, 1, 3) ; 
IF  MPC='W'  THEN  JC*=SUBSTR(MOS,  1, 3)  ]  ]  '  '  ; 


*  CONVERT  SSN  TO  BASE  32  ENCRYPTION 
Kl=lNT(SSN/33554432) ; 
SSN»SSN-K1*33554432  t 
K2=INT(SSN/1048576) ; 
SSN=SSN-K2*1048576 ; 

K3=INT(SSN/32768) ; 

SSN«SSN-K3*32768 ; 

K4=INT(SSN/1024) ; 

SSN=SSN-K4*1024; 

K5=INT(SSN/32)  ; 

SSN*SSN-K5*32; 

K6=SSN; 


PUT  SITE  $4.  K1  CODEl.  K2  CODEl.  K3  CODEl.  K4  CODEl.  K5 
CODEl.  K6  CODEl.  FMP  $2.  DOB  $6.  CAT$3.  LITHO  $7.  C  $1. 
DATE  $6.  SEX  $1.  RACE  $1.  MPC  $1.  PADl  $1.  GRAD  $2.  JC  $4 
W  $1.  UPCl  $5.  PAD3  $3.  ZIP  $5.  PAD12  $12.; 
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001A  0002  1  REM  INPUT  PARAMETERS 

001A  0002  PRINT  "ENTER  INPUT  FILE  PRECEDED  BY  DISK  DESIGNATION 

0037  0002  INPUT  INPFS 

0047  0006  PRINT  "ENTER  OUTPUT  FILE  PRECEDED  BY  DISK  DESIGNATION  "; 

004F  0006  INPUT  OUTFS 

005F  OOOA  PRINT  "ENTER  STARTING  SEQUENCE  NUMBER  "; 

0067  OOOA  INPUT  SEQ 

0077  OOOE  PRINT  "ENTER  SITE  CODE" 

007F  OOOE  PRINT  "USE  FIRST  B^BRAGG  C>CAMPBELL  J-JACKSON  P>POLK  "; 

0087  OOOE  INPUT  CS 

0097  0012  PRINT  "ENTER  CURRENT  DATE  YYMMDO  "; 

009F  0012  INPUT  DATS 

OOAF  0016  CLS 

00B3  0016  PRINT  "INPUT  FILE  "; INPFS 

OOCO  0016  PRINT  "OUTPUT  FILE  ";OUTFS 

OOCD  0016  PRINT  "STARTING  SEQ  NO.  ";SEO 

OODA  0016  PRINT  "SITE  CODE  ";CS 

00E7  0016  PRINT  "CURRENT  OATE  ";DATS 

OOF4  0016  PRINT 

OOFC  0016  PRINT  "VE...FY  ABOVE.  CONTINUE?  (Y/N)  "; 

0104  0016  INPUT  ANSS 

0114  001 A  IF  ANSS<>"Y"  THEN  GOTO  1 

0126  001A  OPEN  INPFS  FOR  INPUT  AS  «1 

0137  001A  OPEN  OUTFS  FOR  OUTPUT  AS  «2 

0149  001A  PROGIDS3"200" 

0152  001E  FMPS»«20" 

0158  0022  CATS>"A10« 

0164  0026  WS^'V 

0160  002A  F I  LS»"«««««««<««««««««««««««««««««" 

0176  002E  IF  ASC(CS)  >  91  THEN  C$<HRS(ASC<CS)-32} 

0194  002E  ZIPS="  " 

0190  0032  IF  CS="8"  THEM  ZIPS="28307" 

0184  0032  IF  CS="C"  THEN  2IPS="42223" 

01C8  0032  IF  CS=<"J"  THEM  ZIPS="29207" 

01E2  0032  IF  CS="P"  THEN  2IPS="71459" 

01 F9  0032 

01 F9  0032  SEQ=SEQ-1 

0206  0032 

0206  0032  100  REM  READ  RECORD 

0207  0032 

0207  0032  IF  E0F(1)  THEN  GOTO  500 

0219  0032  INPUT  »1,AS 

0228  0036  SEQ  =  SEQ  ♦  1 

0235  0036  SSNS  «  LEFTS(AS,9) 

0244  003A  MPCS  =  HIDS(AS,10.1) 

0256  003E  GRADES  >  HIDS(AS,11,1) 

0268  0042  SENS  >  MIDS(AS,12,1) 

d27A  0046  OMOSS  >  MIDS<AS,13,5> 

028C  004A  UPC1S  >  MIDS(AS,18,5) 

029E  004E  DOBS  >  MIDS(AS,23,6) 

0280  0052  RACES  «  MIDS(AS,29,1) 

02C2  0056  IF  LEN(D0BS)=0  THEN  DOOS=«  " 

02D8  0056  IF  LEN(RACES)sO  THEN  RACES=»  " 

''?EF  0056 
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02EE  0056  REM  CONVERT  SEO  NO. 

02EE  0056  SEQNS  >  STRS(SEQ) 

02FA  005A  N  «  LEN(SEQNS) 

0307  005E  SE0NS>  STRINCS(8-N,"0"}  *■  RIGHTSISEONS.N-I) 

0336  005E 

0336  005E  REM  CONVERT  GRADE 

0336  005E  IF  MPCS^xE*  THEN  GOTO  120 

0348  005E  IF  MPCS«”0"  THEN  GOTO  140 

035A  905E  REN  ASSUME  NPC  IS  W 

035A  005E  IF  GRADES>"U"  THEN  GRADES3«04"  :GOTO  160 

0375  005E  IF  GRADES-*^"  THEN  GRADEts«03*  :GOTO  160 

0390  005E  IF  GRA0E$>'V‘  THEN  GltAOES>«02«  :GOTO  160 

03AB  005E  IF  GRADES-xX*  THEN  GRADESa"01"  :GOTO  160 

03C6  005E  PRINT  "ERROR  IN  GRADE  NPC«*;MPCS,"GRADE>";GRAOES 

0300  005E  GRADES^"  " 

03E6  005E  GOTO  160 

03EA  005E 

03EA  005E  120  REN  GRADE  CONVERSION  FOR  MPC>E 

03EB  005E  IF  GRA0ES-"M"  THEN  GRA0ES«"04"  :GOTO  160 

0406  005E  IF  GRA0ES-"N"  THEN  GRADES>"05"  :G0T0  160 

0421  005E  IF  GRA0ES>"O"  THEN  GRADES»"06"  :GOTO  160 

043C  005E  IF  GRA0ES="P«  THEN  GRA0ES«"07"  :G0T0  160 

0457  005E  IF  GRA0ES«"R«  THEN  GRADESa"09"  :OOTO  160 

0472  005E  IF  GRA0ES>"X"  THEN  GRA0E$x"07"  :00T0  160 

0480  005E  IF  OHADE$»"y"  THEN  GHADE$»"08"  :GOTO  160 

04A8  005E  IF  GRAOES-"1"  THEN  6RADES>>»01"  :GOTO  160 

04C3  005E  IF  GRA0ES-«2"  THEN  GRAOE$>"02"  :GOTO  160 

040E  005E  IF  GRA0E$«"3"  THEN  GRADES-"03"  :GOTO  160 

04F9  005E  IF  GRAOES«"4"  THEN  GRA0ES3"04"  :GOTO  160 

0514  005E  IF  GRAOESa"5”  THEN  GRAOES-"OS"  .-GOTO  160 

052F  005E  IF  GRA0ES*"6«  THEN  GRA0ES>"06"  :GOTO  160 

054A  005E  IF  GRA0ES«"7"  THEN  GRADE$«"07"  :GOTO  160 

0565  005E  IF  GRA0ES>"8"  THEN  GRADE$«"08"  :GOTO  160 

0580  005E  IF  GRADE$="9"  THEN  GRAOE$="09«  :GOTO  160 

0598  005E  PRINT  "ERROR  IN  GRADE  NPC=";MPCS,"GRAOE«";GRADES 

05B2  005E  GRADES^"  " 

05BB  005E  GOTO  160 

OSBF  OOSE 

05BF  OOSE  140  REN  GRADE  CONVERSION  WHEN  NPC-0 
05C0  OOSE  IF  GRADES«"A"  THEN  GRAOES«"08"  :GOTO  160 

05DB  OOSE  IF  GRA0ES«*B"  THEN  GRAOES>"06"  -.GOTO  160 

0SF6  OOSE  IF  GRADES>"C"  THEN  GRA0ESs"0S"  :GOTO  160 

0611  OOSE  IF  GRADE$-"0"  THEN  6RADES>"04"  :G0T0  160 

062C  OOSE  IF  GRA0ES>"E"  THEN  GRAOE$>"03"  :G0T0  160 

0647  OOSE  IF  GRA0E$>"F«  THEN  GRA0ES«"02"  :G0T0  160 

0662  OOSE  IF  GRAOES>"G"  THEN  GRA0ES>"01"  :G0T0  160 

067D  OOSE  IF  GRA0ES-"5"  THEN  GRAOES>"03"  :G0T0  160 

0698  OOSE  IF  GRADES3"6"  THEN  GRADES>"02"  :GOTO  160 

0683  OOSE  IF  GRADES»"7"  THEN  GRADES«"01"  :Q0T0  160 

06CE  OOSE  PRINT  "ERROR  IN  GRADE  MPC-";MPCS,"GRADE>"; GRADES 

06E5  OOSE  GRAOESo”  " 

06EE  OOSE 

06EE  OOSE  160  REM  END  OF  GRADE  CONVERSION 
06EF  OOSE 
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06EF 

OOSE 

REM  CONVERT  RACE 

06EF 

005E 

IF  RACES*"  "  THEN  RACES«"7" 

0706 

005E 

IF  RACES>"C"  THEN  RACES*"5" 

0710 

OOSE 

IF  RACES>"M”  THEN  RACES«"2" 

0734 

OOSE 

IF  RACES«"N"  THEN  RACES*"4" 

0748 

OOSE 

IF  RACES-"R"  THEN  RACES«"1" 

0762 

OOSE 

IF  RACES«"X*  THEN  RACES*"7" 

0779 

OOSE 

0779 

OOSE 

REM  CONVERT  JO8C0OE 

0779 

005E 

JCS  *  LEFTS(DMOSS,3) 

0788 

0062 

IF  MPCS«"E"  THEN  JCS«  "0"*JCS 

07A3 

0062 

IF  MPCS>«0"  THEN  JCS*  *0"'»JCS 

07BE 

0062 

IF  MPCS*"U"  THEN  JCS*  JCS*"  " 

0708 

0062 

0708 

0062 

REM  BUILD  OUTPUT  RECORD 

0708 

0062 

RECS*PROGIDS  *  SSHS  *  FMPS  *  DOBS  *  CATS  *  SEQNS  *  CS 

0804 

0066 

RECS*RECS  *  DATS  *  SENS  *  RACES  *  MPCS  *  "  "  *  GRADES 

082F 

0066 

RECS-RECS  *  JCS  *  US  *  UPC1S  *  "  "  *  ZIPS  *  " 

085A 

0066 

RECS*RECS  *  FILS 

0866 

0066 

0866 

0066 

PRINT  B2.RECS 

0871 

0066 

GOTO  100 

0875 

0066 

0875 

0066 

500  REM  CLOSE  FILES  AND  QUIT 

0876 

0066 

CLOSE  1,2 

0883 

0066 

END 

0887 

0066 

OSSA 

0066 

22151 

Bytes  Avsi table 

19949  Bytes  Free 


0  Warning  Error(s) 
0  Severe  Errorts) 


